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         dxi=dc(1,i)
3163         dyi=dc(2,i)
3164         dzi=dc(3,i)
3165         dx_normi=dc_norm(1,i)
3166         dy_normi=dc_norm(2,i)
3167         dz_normi=dc_norm(3,i)
3168         xmedi=c(1,i)+0.5d0*dxi
3169         ymedi=c(2,i)+0.5d0*dyi
3170         zmedi=c(3,i)+0.5d0*dzi
3171           xmedi=dmod(xmedi,boxxsize)
3172           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3173           ymedi=dmod(ymedi,boxysize)
3174           if (ymedi.lt.0) ymedi=ymedi+boxysize
3175           zmedi=dmod(zmedi,boxzsize)
3176           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3177        if ((zmedi.gt.bordlipbot)  &
3178        .and.(zmedi.lt.bordliptop)) then
3179 !C the energy transfer exist
3180         if (zmedi.lt.buflipbot) then
3181 !C what fraction I am in
3182          fracinbuf=1.0d0- &
3183              ((zmedi-bordlipbot)/lipbufthick)
3184 !C lipbufthick is thickenes of lipid buffore
3185          sslipi=sscalelip(fracinbuf)
3186          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3187         elseif (zmedi.gt.bufliptop) then
3188          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3189          sslipi=sscalelip(fracinbuf)
3190          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3191         else
3192          sslipi=1.0d0
3193          ssgradlipi=0.0
3194         endif
3195        else
3196          sslipi=0.0d0
3197          ssgradlipi=0.0
3198        endif
3199
3200         num_conti=num_cont_hb(i)
3201         call eelecij(i,i+3,ees,evdw1,eel_loc)
3202         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3203          call eturn4(i,eello_turn4)
3204         num_cont_hb(i)=num_conti
3205       enddo   ! i
3206 !
3207 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3208 !
3209 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3210       do i=iatel_s,iatel_e
3211         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3212         dxi=dc(1,i)
3213         dyi=dc(2,i)
3214         dzi=dc(3,i)
3215         dx_normi=dc_norm(1,i)
3216         dy_normi=dc_norm(2,i)
3217         dz_normi=dc_norm(3,i)
3218         xmedi=c(1,i)+0.5d0*dxi
3219         ymedi=c(2,i)+0.5d0*dyi
3220         zmedi=c(3,i)+0.5d0*dzi
3221           xmedi=dmod(xmedi,boxxsize)
3222           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3223           ymedi=dmod(ymedi,boxysize)
3224           if (ymedi.lt.0) ymedi=ymedi+boxysize
3225           zmedi=dmod(zmedi,boxzsize)
3226           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3227        if ((zmedi.gt.bordlipbot)  &
3228         .and.(zmedi.lt.bordliptop)) then
3229 !C the energy transfer exist
3230         if (zmedi.lt.buflipbot) then
3231 !C what fraction I am in
3232          fracinbuf=1.0d0- &
3233              ((zmedi-bordlipbot)/lipbufthick)
3234 !C lipbufthick is thickenes of lipid buffore
3235          sslipi=sscalelip(fracinbuf)
3236          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3237         elseif (zmedi.gt.bufliptop) then
3238          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3239          sslipi=sscalelip(fracinbuf)
3240          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3241         else
3242          sslipi=1.0d0
3243          ssgradlipi=0.0
3244         endif
3245        else
3246          sslipi=0.0d0
3247          ssgradlipi=0.0
3248        endif
3249
3250 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3251         num_conti=num_cont_hb(i)
3252         do j=ielstart(i),ielend(i)
3253 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3254           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3255           call eelecij(i,j,ees,evdw1,eel_loc)
3256         enddo ! j
3257         num_cont_hb(i)=num_conti
3258       enddo   ! i
3259 !      write (iout,*) "Number of loop steps in EELEC:",ind
3260 !d      do i=1,nres
3261 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3262 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3263 !d      enddo
3264 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3265 !cc      eel_loc=eel_loc+eello_turn3
3266 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3267       return
3268       end subroutine eelec
3269 !-----------------------------------------------------------------------------
3270       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3271
3272       use comm_locel
3273 !      implicit real*8 (a-h,o-z)
3274 !      include 'DIMENSIONS'
3275 #ifdef MPI
3276       include "mpif.h"
3277 #endif
3278 !      include 'COMMON.CONTROL'
3279 !      include 'COMMON.IOUNITS'
3280 !      include 'COMMON.GEO'
3281 !      include 'COMMON.VAR'
3282 !      include 'COMMON.LOCAL'
3283 !      include 'COMMON.CHAIN'
3284 !      include 'COMMON.DERIV'
3285 !      include 'COMMON.INTERACT'
3286 !      include 'COMMON.CONTACTS'
3287 !      include 'COMMON.TORSION'
3288 !      include 'COMMON.VECTORS'
3289 !      include 'COMMON.FFIELD'
3290 !      include 'COMMON.TIME1'
3291       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3292       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3293       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3294 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3295       real(kind=8),dimension(4) :: muij
3296       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3297                     dist_temp, dist_init,rlocshield,fracinbuf
3298       integer xshift,yshift,zshift,ilist,iresshield
3299 !el      integer :: num_conti,j1,j2
3300 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3301 !el        dz_normi,xmedi,ymedi,zmedi
3302
3303 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3304 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3305 !el          num_conti,j1,j2
3306
3307 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3308 #ifdef MOMENT
3309       real(kind=8) :: scal_el=1.0d0
3310 #else
3311       real(kind=8) :: scal_el=0.5d0
3312 #endif
3313 ! 12/13/98
3314 ! 13-go grudnia roku pamietnego...
3315       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3316                                              0.0d0,1.0d0,0.0d0,&
3317                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3318 !      integer :: maxconts=nres/4
3319 !el local variables
3320       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3321       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3322       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3323       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3324                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3325                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3326                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3327                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3328                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3329                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3330                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3331 !      maxconts=nres/4
3332 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3333 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3334
3335 !          time00=MPI_Wtime()
3336 !d      write (iout,*) "eelecij",i,j
3337 !          ind=ind+1
3338           iteli=itel(i)
3339           itelj=itel(j)
3340           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3341           aaa=app(iteli,itelj)
3342           bbb=bpp(iteli,itelj)
3343           ael6i=ael6(iteli,itelj)
3344           ael3i=ael3(iteli,itelj)
3345           dxj=dc(1,j)
3346           dyj=dc(2,j)
3347           dzj=dc(3,j)
3348           dx_normj=dc_norm(1,j)
3349           dy_normj=dc_norm(2,j)
3350           dz_normj=dc_norm(3,j)
3351 !          xj=c(1,j)+0.5D0*dxj-xmedi
3352 !          yj=c(2,j)+0.5D0*dyj-ymedi
3353 !          zj=c(3,j)+0.5D0*dzj-zmedi
3354           xj=c(1,j)+0.5D0*dxj
3355           yj=c(2,j)+0.5D0*dyj
3356           zj=c(3,j)+0.5D0*dzj
3357           xj=mod(xj,boxxsize)
3358           if (xj.lt.0) xj=xj+boxxsize
3359           yj=mod(yj,boxysize)
3360           if (yj.lt.0) yj=yj+boxysize
3361           zj=mod(zj,boxzsize)
3362           if (zj.lt.0) zj=zj+boxzsize
3363        if ((zj.gt.bordlipbot)  &
3364        .and.(zj.lt.bordliptop)) then
3365 !C the energy transfer exist
3366         if (zj.lt.buflipbot) then
3367 !C what fraction I am in
3368          fracinbuf=1.0d0-     &
3369              ((zj-bordlipbot)/lipbufthick)
3370 !C lipbufthick is thickenes of lipid buffore
3371          sslipj=sscalelip(fracinbuf)
3372          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3373         elseif (zj.gt.bufliptop) then
3374          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3375          sslipj=sscalelip(fracinbuf)
3376          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3377         else
3378          sslipj=1.0d0
3379          ssgradlipj=0.0
3380         endif
3381        else
3382          sslipj=0.0d0
3383          ssgradlipj=0.0
3384        endif
3385
3386       isubchap=0
3387       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3388       xj_safe=xj
3389       yj_safe=yj
3390       zj_safe=zj
3391       do xshift=-1,1
3392       do yshift=-1,1
3393       do zshift=-1,1
3394           xj=xj_safe+xshift*boxxsize
3395           yj=yj_safe+yshift*boxysize
3396           zj=zj_safe+zshift*boxzsize
3397           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3398           if(dist_temp.lt.dist_init) then
3399             dist_init=dist_temp
3400             xj_temp=xj
3401             yj_temp=yj
3402             zj_temp=zj
3403             isubchap=1
3404           endif
3405        enddo
3406        enddo
3407        enddo
3408        if (isubchap.eq.1) then
3409 !C          print *,i,j
3410           xj=xj_temp-xmedi
3411           yj=yj_temp-ymedi
3412           zj=zj_temp-zmedi
3413        else
3414           xj=xj_safe-xmedi
3415           yj=yj_safe-ymedi
3416           zj=zj_safe-zmedi
3417        endif
3418
3419           rij=xj*xj+yj*yj+zj*zj
3420           rrmij=1.0D0/rij
3421           rij=dsqrt(rij)
3422 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3423             sss_ele_cut=sscale_ele(rij)
3424             sss_ele_grad=sscagrad_ele(rij)
3425 !             sss_ele_cut=1.0d0
3426 !             sss_ele_grad=0.0d0
3427 !            print *,sss_ele_cut,sss_ele_grad,&
3428 !            (rij),r_cut_ele,rlamb_ele
3429 !            if (sss_ele_cut.le.0.0) go to 128
3430
3431           rmij=1.0D0/rij
3432           r3ij=rrmij*rmij
3433           r6ij=r3ij*r3ij
3434           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3435           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3436           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3437           fac=cosa-3.0D0*cosb*cosg
3438           ev1=aaa*r6ij*r6ij
3439 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3440           if (j.eq.i+2) ev1=scal_el*ev1
3441           ev2=bbb*r6ij
3442           fac3=ael6i*r6ij
3443           fac4=ael3i*r3ij
3444           evdwij=ev1+ev2
3445           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3446           el2=fac4*fac
3447 !          eesij=el1+el2
3448           if (shield_mode.gt.0) then
3449 !C          fac_shield(i)=0.4
3450 !C          fac_shield(j)=0.6
3451           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3452           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3453           eesij=(el1+el2)
3454           ees=ees+eesij*sss_ele_cut
3455 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3456 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3457           else
3458           fac_shield(i)=1.0
3459           fac_shield(j)=1.0
3460           eesij=(el1+el2)
3461           ees=ees+eesij   &
3462             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3463 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3464           endif
3465
3466 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3467           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3468 !          ees=ees+eesij*sss_ele_cut
3469           evdw1=evdw1+evdwij*sss_ele_cut  &
3470            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3471 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3472 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3473 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3474 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3475
3476           if (energy_dec) then
3477 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3478 !                  'evdw1',i,j,evdwij,&
3479 !                  iteli,itelj,aaa,evdw1
3480               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3481               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3482           endif
3483 !
3484 ! Calculate contributions to the Cartesian gradient.
3485 !
3486 #ifdef SPLITELE
3487           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3488               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3489           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3490              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3491           fac1=fac
3492           erij(1)=xj*rmij
3493           erij(2)=yj*rmij
3494           erij(3)=zj*rmij
3495 !
3496 ! Radial derivatives. First process both termini of the fragment (i,j)
3497 !
3498           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3499           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3500           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3501            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3502           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3503             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3504
3505           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3506           (shield_mode.gt.0)) then
3507 !C          print *,i,j
3508           do ilist=1,ishield_list(i)
3509            iresshield=shield_list(ilist,i)
3510            do k=1,3
3511            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3512            *2.0*sss_ele_cut
3513            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3514                    rlocshield &
3515             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3516             *sss_ele_cut
3517             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3518            enddo
3519           enddo
3520           do ilist=1,ishield_list(j)
3521            iresshield=shield_list(ilist,j)
3522            do k=1,3
3523            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3524           *2.0*sss_ele_cut
3525            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3526                    rlocshield &
3527            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3528            *sss_ele_cut
3529            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3530            enddo
3531           enddo
3532           do k=1,3
3533             gshieldc(k,i)=gshieldc(k,i)+ &
3534                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3535            *sss_ele_cut
3536
3537             gshieldc(k,j)=gshieldc(k,j)+ &
3538                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3539            *sss_ele_cut
3540
3541             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3542                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3543            *sss_ele_cut
3544
3545             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3546                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3547            *sss_ele_cut
3548
3549            enddo
3550            endif
3551
3552
3553 !          do k=1,3
3554 !            ghalf=0.5D0*ggg(k)
3555 !            gelc(k,i)=gelc(k,i)+ghalf
3556 !            gelc(k,j)=gelc(k,j)+ghalf
3557 !          enddo
3558 ! 9/28/08 AL Gradient compotents will be summed only at the end
3559           do k=1,3
3560             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3561             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3562           enddo
3563             gelc_long(3,j)=gelc_long(3,j)+  &
3564           ssgradlipj*eesij/2.0d0*lipscale**2&
3565            *sss_ele_cut
3566
3567             gelc_long(3,i)=gelc_long(3,i)+  &
3568           ssgradlipi*eesij/2.0d0*lipscale**2&
3569            *sss_ele_cut
3570
3571
3572 !
3573 ! Loop over residues i+1 thru j-1.
3574 !
3575 !grad          do k=i+1,j-1
3576 !grad            do l=1,3
3577 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3578 !grad            enddo
3579 !grad          enddo
3580           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3581            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3582           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3583            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3584           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3585            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3586
3587 !          do k=1,3
3588 !            ghalf=0.5D0*ggg(k)
3589 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3590 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3591 !          enddo
3592 ! 9/28/08 AL Gradient compotents will be summed only at the end
3593           do k=1,3
3594             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3595             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3596           enddo
3597
3598 !C Lipidic part for scaling weight
3599            gvdwpp(3,j)=gvdwpp(3,j)+ &
3600           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3601            gvdwpp(3,i)=gvdwpp(3,i)+ &
3602           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3603 !! Loop over residues i+1 thru j-1.
3604 !
3605 !grad          do k=i+1,j-1
3606 !grad            do l=1,3
3607 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3608 !grad            enddo
3609 !grad          enddo
3610 #else
3611           facvdw=(ev1+evdwij)*sss_ele_cut &
3612            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3613
3614           facel=(el1+eesij)*sss_ele_cut
3615           fac1=fac
3616           fac=-3*rrmij*(facvdw+facvdw+facel)
3617           erij(1)=xj*rmij
3618           erij(2)=yj*rmij
3619           erij(3)=zj*rmij
3620 !
3621 ! Radial derivatives. First process both termini of the fragment (i,j)
3622 !
3623           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3624           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3625           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3626 !          do k=1,3
3627 !            ghalf=0.5D0*ggg(k)
3628 !            gelc(k,i)=gelc(k,i)+ghalf
3629 !            gelc(k,j)=gelc(k,j)+ghalf
3630 !          enddo
3631 ! 9/28/08 AL Gradient compotents will be summed only at the end
3632           do k=1,3
3633             gelc_long(k,j)=gelc(k,j)+ggg(k)
3634             gelc_long(k,i)=gelc(k,i)-ggg(k)
3635           enddo
3636 !
3637 ! Loop over residues i+1 thru j-1.
3638 !
3639 !grad          do k=i+1,j-1
3640 !grad            do l=1,3
3641 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3642 !grad            enddo
3643 !grad          enddo
3644 ! 9/28/08 AL Gradient compotents will be summed only at the end
3645           ggg(1)=facvdw*xj &
3646            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3647           ggg(2)=facvdw*yj &
3648            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3649           ggg(3)=facvdw*zj &
3650            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3651
3652           do k=1,3
3653             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3654             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3655           enddo
3656            gvdwpp(3,j)=gvdwpp(3,j)+ &
3657           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3658            gvdwpp(3,i)=gvdwpp(3,i)+ &
3659           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3660
3661 #endif
3662 !
3663 ! Angular part
3664 !
3665           ecosa=2.0D0*fac3*fac1+fac4
3666           fac4=-3.0D0*fac4
3667           fac3=-6.0D0*fac3
3668           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3669           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3670           do k=1,3
3671             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3672             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3673           enddo
3674 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3675 !d   &          (dcosg(k),k=1,3)
3676           do k=1,3
3677             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3678              *fac_shield(i)**2*fac_shield(j)**2 &
3679              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3680
3681           enddo
3682 !          do k=1,3
3683 !            ghalf=0.5D0*ggg(k)
3684 !            gelc(k,i)=gelc(k,i)+ghalf
3685 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3686 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3687 !            gelc(k,j)=gelc(k,j)+ghalf
3688 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3689 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3690 !          enddo
3691 !grad          do k=i+1,j-1
3692 !grad            do l=1,3
3693 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3694 !grad            enddo
3695 !grad          enddo
3696           do k=1,3
3697             gelc(k,i)=gelc(k,i) &
3698                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3699                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3700                      *sss_ele_cut &
3701                      *fac_shield(i)**2*fac_shield(j)**2 &
3702                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3703
3704             gelc(k,j)=gelc(k,j) &
3705                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3706                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3707                      *sss_ele_cut  &
3708                      *fac_shield(i)**2*fac_shield(j)**2  &
3709                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3710
3711             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3712             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3713           enddo
3714
3715           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3716               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3717               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3718 !
3719 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3720 !   energy of a peptide unit is assumed in the form of a second-order
3721 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3722 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3723 !   are computed for EVERY pair of non-contiguous peptide groups.
3724 !
3725           if (j.lt.nres-1) then
3726             j1=j+1
3727             j2=j-1
3728           else
3729             j1=j-1
3730             j2=j-2
3731           endif
3732           kkk=0
3733           do k=1,2
3734             do l=1,2
3735               kkk=kkk+1
3736               muij(kkk)=mu(k,i)*mu(l,j)
3737             enddo
3738           enddo
3739 !d         write (iout,*) 'EELEC: i',i,' j',j
3740 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3741 !d          write(iout,*) 'muij',muij
3742           ury=scalar(uy(1,i),erij)
3743           urz=scalar(uz(1,i),erij)
3744           vry=scalar(uy(1,j),erij)
3745           vrz=scalar(uz(1,j),erij)
3746           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3747           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3748           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3749           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3750           fac=dsqrt(-ael6i)*r3ij
3751           a22=a22*fac
3752           a23=a23*fac
3753           a32=a32*fac
3754           a33=a33*fac
3755 !d          write (iout,'(4i5,4f10.5)')
3756 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3757 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3758 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3759 !d     &      uy(:,j),uz(:,j)
3760 !d          write (iout,'(4f10.5)')
3761 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3762 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3763 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3764 !d           write (iout,'(9f10.5/)')
3765 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3766 ! Derivatives of the elements of A in virtual-bond vectors
3767           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3768           do k=1,3
3769             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3770             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3771             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3772             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3773             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3774             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3775             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3776             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3777             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3778             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3779             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3780             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3781           enddo
3782 ! Compute radial contributions to the gradient
3783           facr=-3.0d0*rrmij
3784           a22der=a22*facr
3785           a23der=a23*facr
3786           a32der=a32*facr
3787           a33der=a33*facr
3788           agg(1,1)=a22der*xj
3789           agg(2,1)=a22der*yj
3790           agg(3,1)=a22der*zj
3791           agg(1,2)=a23der*xj
3792           agg(2,2)=a23der*yj
3793           agg(3,2)=a23der*zj
3794           agg(1,3)=a32der*xj
3795           agg(2,3)=a32der*yj
3796           agg(3,3)=a32der*zj
3797           agg(1,4)=a33der*xj
3798           agg(2,4)=a33der*yj
3799           agg(3,4)=a33der*zj
3800 ! Add the contributions coming from er
3801           fac3=-3.0d0*fac
3802           do k=1,3
3803             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3804             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3805             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3806             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3807           enddo
3808           do k=1,3
3809 ! Derivatives in DC(i)
3810 !grad            ghalf1=0.5d0*agg(k,1)
3811 !grad            ghalf2=0.5d0*agg(k,2)
3812 !grad            ghalf3=0.5d0*agg(k,3)
3813 !grad            ghalf4=0.5d0*agg(k,4)
3814             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3815             -3.0d0*uryg(k,2)*vry)!+ghalf1
3816             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3817             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3818             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3819             -3.0d0*urzg(k,2)*vry)!+ghalf3
3820             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3821             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3822 ! Derivatives in DC(i+1)
3823             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3824             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3825             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3826             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3827             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3828             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3829             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3830             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3831 ! Derivatives in DC(j)
3832             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3833             -3.0d0*vryg(k,2)*ury)!+ghalf1
3834             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3835             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3836             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3837             -3.0d0*vryg(k,2)*urz)!+ghalf3
3838             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3839             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3840 ! Derivatives in DC(j+1) or DC(nres-1)
3841             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3842             -3.0d0*vryg(k,3)*ury)
3843             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3844             -3.0d0*vrzg(k,3)*ury)
3845             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3846             -3.0d0*vryg(k,3)*urz)
3847             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3848             -3.0d0*vrzg(k,3)*urz)
3849 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3850 !grad              do l=1,4
3851 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3852 !grad              enddo
3853 !grad            endif
3854           enddo
3855           acipa(1,1)=a22
3856           acipa(1,2)=a23
3857           acipa(2,1)=a32
3858           acipa(2,2)=a33
3859           a22=-a22
3860           a23=-a23
3861           do l=1,2
3862             do k=1,3
3863               agg(k,l)=-agg(k,l)
3864               aggi(k,l)=-aggi(k,l)
3865               aggi1(k,l)=-aggi1(k,l)
3866               aggj(k,l)=-aggj(k,l)
3867               aggj1(k,l)=-aggj1(k,l)
3868             enddo
3869           enddo
3870           if (j.lt.nres-1) then
3871             a22=-a22
3872             a32=-a32
3873             do l=1,3,2
3874               do k=1,3
3875                 agg(k,l)=-agg(k,l)
3876                 aggi(k,l)=-aggi(k,l)
3877                 aggi1(k,l)=-aggi1(k,l)
3878                 aggj(k,l)=-aggj(k,l)
3879                 aggj1(k,l)=-aggj1(k,l)
3880               enddo
3881             enddo
3882           else
3883             a22=-a22
3884             a23=-a23
3885             a32=-a32
3886             a33=-a33
3887             do l=1,4
3888               do k=1,3
3889                 agg(k,l)=-agg(k,l)
3890                 aggi(k,l)=-aggi(k,l)
3891                 aggi1(k,l)=-aggi1(k,l)
3892                 aggj(k,l)=-aggj(k,l)
3893                 aggj1(k,l)=-aggj1(k,l)
3894               enddo
3895             enddo
3896           endif
3897           ENDIF ! WCORR
3898           IF (wel_loc.gt.0.0d0) THEN
3899 ! Contribution to the local-electrostatic energy coming from the i-j pair
3900           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3901            +a33*muij(4)
3902           if (shield_mode.eq.0) then
3903            fac_shield(i)=1.0
3904            fac_shield(j)=1.0
3905           endif
3906           eel_loc_ij=eel_loc_ij &
3907          *fac_shield(i)*fac_shield(j) &
3908          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3909 !C Now derivative over eel_loc
3910           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3911          (shield_mode.gt.0)) then
3912 !C          print *,i,j
3913
3914           do ilist=1,ishield_list(i)
3915            iresshield=shield_list(ilist,i)
3916            do k=1,3
3917            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3918                                                 /fac_shield(i)&
3919            *sss_ele_cut
3920            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3921                    rlocshield  &
3922           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3923           *sss_ele_cut
3924
3925             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3926            +rlocshield
3927            enddo
3928           enddo
3929           do ilist=1,ishield_list(j)
3930            iresshield=shield_list(ilist,j)
3931            do k=1,3
3932            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3933                                             /fac_shield(j)   &
3934             *sss_ele_cut
3935            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3936                    rlocshield  &
3937       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3938        *sss_ele_cut
3939
3940            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3941                   +rlocshield
3942
3943            enddo
3944           enddo
3945
3946           do k=1,3
3947             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3948                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3949                     *sss_ele_cut
3950             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3951                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3952                     *sss_ele_cut
3953             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3954                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3955                     *sss_ele_cut
3956             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3957                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3958                     *sss_ele_cut
3959
3960            enddo
3961            endif
3962
3963
3964 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3965 !           eel_loc_ij=0.0
3966 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3967 !                  'eelloc',i,j,eel_loc_ij
3968           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
3969                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3970 !           print *,"EELLOC",i,gel_loc_loc(i-1)
3971
3972 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3973 !          if (energy_dec) write (iout,*) "muij",muij
3974 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3975
3976           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3977 ! Partial derivatives in virtual-bond dihedral angles gamma
3978           if (i.gt.1) &
3979           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3980                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3981                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3982                  *sss_ele_cut  &
3983           *fac_shield(i)*fac_shield(j) &
3984           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3985
3986           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3987                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3988                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3989                  *sss_ele_cut &
3990           *fac_shield(i)*fac_shield(j) &
3991           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3992 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3993 !          do l=1,3
3994 !            ggg(1)=(agg(1,1)*muij(1)+ &
3995 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3996 !            *sss_ele_cut &
3997 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3998 !            ggg(2)=(agg(2,1)*muij(1)+ &
3999 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4000 !            *sss_ele_cut &
4001 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4002 !            ggg(3)=(agg(3,1)*muij(1)+ &
4003 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4004 !            *sss_ele_cut &
4005 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4006            xtemp(1)=xj
4007            xtemp(2)=yj
4008            xtemp(3)=zj
4009
4010            do l=1,3
4011             ggg(l)=(agg(l,1)*muij(1)+ &
4012                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4013             *sss_ele_cut &
4014           *fac_shield(i)*fac_shield(j) &
4015           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4016              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4017
4018
4019             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4020             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4021 !grad            ghalf=0.5d0*ggg(l)
4022 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4023 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4024           enddo
4025             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4026           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4027           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4028
4029             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4030           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4031           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4032
4033 !grad          do k=i+1,j2
4034 !grad            do l=1,3
4035 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4036 !grad            enddo
4037 !grad          enddo
4038 ! Remaining derivatives of eello
4039           do l=1,3
4040             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4041                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4042             *sss_ele_cut &
4043           *fac_shield(i)*fac_shield(j) &
4044           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4045
4046 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4047             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4048                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4049             +aggi1(l,4)*muij(4))&
4050             *sss_ele_cut &
4051           *fac_shield(i)*fac_shield(j) &
4052           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4053
4054 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4055             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4056                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4057             *sss_ele_cut &
4058           *fac_shield(i)*fac_shield(j) &
4059           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4060
4061 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4062             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4063                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4064             +aggj1(l,4)*muij(4))&
4065             *sss_ele_cut &
4066           *fac_shield(i)*fac_shield(j) &
4067          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4068
4069 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4070           enddo
4071           ENDIF
4072 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4073 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4074           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4075              .and. num_conti.le.maxconts) then
4076 !            write (iout,*) i,j," entered corr"
4077 !
4078 ! Calculate the contact function. The ith column of the array JCONT will
4079 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4080 ! greater than I). The arrays FACONT and GACONT will contain the values of
4081 ! the contact function and its derivative.
4082 !           r0ij=1.02D0*rpp(iteli,itelj)
4083 !           r0ij=1.11D0*rpp(iteli,itelj)
4084             r0ij=2.20D0*rpp(iteli,itelj)
4085 !           r0ij=1.55D0*rpp(iteli,itelj)
4086             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4087 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4088             if (fcont.gt.0.0D0) then
4089               num_conti=num_conti+1
4090               if (num_conti.gt.maxconts) then
4091 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4092 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4093                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4094                                ' will skip next contacts for this conf.', num_conti
4095               else
4096                 jcont_hb(num_conti,i)=j
4097 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4098 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4099                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4100                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4101 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4102 !  terms.
4103                 d_cont(num_conti,i)=rij
4104 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4105 !     --- Electrostatic-interaction matrix ---
4106                 a_chuj(1,1,num_conti,i)=a22
4107                 a_chuj(1,2,num_conti,i)=a23
4108                 a_chuj(2,1,num_conti,i)=a32
4109                 a_chuj(2,2,num_conti,i)=a33
4110 !     --- Gradient of rij
4111                 do kkk=1,3
4112                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4113                 enddo
4114                 kkll=0
4115                 do k=1,2
4116                   do l=1,2
4117                     kkll=kkll+1
4118                     do m=1,3
4119                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4120                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4121                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4122                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4123                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4124                     enddo
4125                   enddo
4126                 enddo
4127                 ENDIF
4128                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4129 ! Calculate contact energies
4130                 cosa4=4.0D0*cosa
4131                 wij=cosa-3.0D0*cosb*cosg
4132                 cosbg1=cosb+cosg
4133                 cosbg2=cosb-cosg
4134 !               fac3=dsqrt(-ael6i)/r0ij**3
4135                 fac3=dsqrt(-ael6i)*r3ij
4136 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4137                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4138                 if (ees0tmp.gt.0) then
4139                   ees0pij=dsqrt(ees0tmp)
4140                 else
4141                   ees0pij=0
4142                 endif
4143                 if (shield_mode.eq.0) then
4144                 fac_shield(i)=1.0d0
4145                 fac_shield(j)=1.0d0
4146                 else
4147                 ees0plist(num_conti,i)=j
4148                 endif
4149 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4150                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4151                 if (ees0tmp.gt.0) then
4152                   ees0mij=dsqrt(ees0tmp)
4153                 else
4154                   ees0mij=0
4155                 endif
4156 !               ees0mij=0.0D0
4157                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4158                      *sss_ele_cut &
4159                      *fac_shield(i)*fac_shield(j)
4160
4161                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4162                      *sss_ele_cut &
4163                      *fac_shield(i)*fac_shield(j)
4164
4165 ! Diagnostics. Comment out or remove after debugging!
4166 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4167 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4168 !               ees0m(num_conti,i)=0.0D0
4169 ! End diagnostics.
4170 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4171 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4172 ! Angular derivatives of the contact function
4173                 ees0pij1=fac3/ees0pij
4174                 ees0mij1=fac3/ees0mij
4175                 fac3p=-3.0D0*fac3*rrmij
4176                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4177                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4178 !               ees0mij1=0.0D0
4179                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4180                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4181                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4182                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4183                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4184                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4185                 ecosap=ecosa1+ecosa2
4186                 ecosbp=ecosb1+ecosb2
4187                 ecosgp=ecosg1+ecosg2
4188                 ecosam=ecosa1-ecosa2
4189                 ecosbm=ecosb1-ecosb2
4190                 ecosgm=ecosg1-ecosg2
4191 ! Diagnostics
4192 !               ecosap=ecosa1
4193 !               ecosbp=ecosb1
4194 !               ecosgp=ecosg1
4195 !               ecosam=0.0D0
4196 !               ecosbm=0.0D0
4197 !               ecosgm=0.0D0
4198 ! End diagnostics
4199                 facont_hb(num_conti,i)=fcont
4200                 fprimcont=fprimcont/rij
4201 !d              facont_hb(num_conti,i)=1.0D0
4202 ! Following line is for diagnostics.
4203 !d              fprimcont=0.0D0
4204                 do k=1,3
4205                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4206                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4207                 enddo
4208                 do k=1,3
4209                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4210                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4211                 enddo
4212                 gggp(1)=gggp(1)+ees0pijp*xj &
4213                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4214                 gggp(2)=gggp(2)+ees0pijp*yj &
4215                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4216                 gggp(3)=gggp(3)+ees0pijp*zj &
4217                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4218
4219                 gggm(1)=gggm(1)+ees0mijp*xj &
4220                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4221
4222                 gggm(2)=gggm(2)+ees0mijp*yj &
4223                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4224
4225                 gggm(3)=gggm(3)+ees0mijp*zj &
4226                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4227
4228 ! Derivatives due to the contact function
4229                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4230                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4231                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4232                 do k=1,3
4233 !
4234 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4235 !          following the change of gradient-summation algorithm.
4236 !
4237 !grad                  ghalfp=0.5D0*gggp(k)
4238 !grad                  ghalfm=0.5D0*gggm(k)
4239                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4240                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4241                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4242                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4243
4244                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4245                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4246                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4247                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4248
4249                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4250                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4251
4252                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4253                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4254                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4255                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4256
4257                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4258                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4259                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4260                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4261
4262                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4263                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4264
4265                 enddo
4266 ! Diagnostics. Comment out or remove after debugging!
4267 !diag           do k=1,3
4268 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4269 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4270 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4271 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4272 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4273 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4274 !diag           enddo
4275               ENDIF ! wcorr
4276               endif  ! num_conti.le.maxconts
4277             endif  ! fcont.gt.0
4278           endif    ! j.gt.i+1
4279           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4280             do k=1,4
4281               do l=1,3
4282                 ghalf=0.5d0*agg(l,k)
4283                 aggi(l,k)=aggi(l,k)+ghalf
4284                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4285                 aggj(l,k)=aggj(l,k)+ghalf
4286               enddo
4287             enddo
4288             if (j.eq.nres-1 .and. i.lt.j-2) then
4289               do k=1,4
4290                 do l=1,3
4291                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4292                 enddo
4293               enddo
4294             endif
4295           endif
4296  128  continue
4297 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4298       return
4299       end subroutine eelecij
4300 !-----------------------------------------------------------------------------
4301       subroutine eturn3(i,eello_turn3)
4302 ! Third- and fourth-order contributions from turns
4303
4304       use comm_locel
4305 !      implicit real*8 (a-h,o-z)
4306 !      include 'DIMENSIONS'
4307 !      include 'COMMON.IOUNITS'
4308 !      include 'COMMON.GEO'
4309 !      include 'COMMON.VAR'
4310 !      include 'COMMON.LOCAL'
4311 !      include 'COMMON.CHAIN'
4312 !      include 'COMMON.DERIV'
4313 !      include 'COMMON.INTERACT'
4314 !      include 'COMMON.CONTACTS'
4315 !      include 'COMMON.TORSION'
4316 !      include 'COMMON.VECTORS'
4317 !      include 'COMMON.FFIELD'
4318 !      include 'COMMON.CONTROL'
4319       real(kind=8),dimension(3) :: ggg
4320       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4321         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4322       real(kind=8),dimension(2) :: auxvec,auxvec1
4323 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4324       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4325 !el      integer :: num_conti,j1,j2
4326 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4327 !el        dz_normi,xmedi,ymedi,zmedi
4328
4329 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4330 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4331 !el         num_conti,j1,j2
4332 !el local variables
4333       integer :: i,j,l,k,ilist,iresshield
4334       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4335
4336       j=i+2
4337 !      write (iout,*) "eturn3",i,j,j1,j2
4338           zj=(c(3,j)+c(3,j+1))/2.0d0
4339           zj=mod(zj,boxzsize)
4340           if (zj.lt.0) zj=zj+boxzsize
4341           if ((zj.lt.0)) write (*,*) "CHUJ"
4342        if ((zj.gt.bordlipbot)  &
4343         .and.(zj.lt.bordliptop)) then
4344 !C the energy transfer exist
4345         if (zj.lt.buflipbot) then
4346 !C what fraction I am in
4347          fracinbuf=1.0d0-     &
4348              ((zj-bordlipbot)/lipbufthick)
4349 !C lipbufthick is thickenes of lipid buffore
4350          sslipj=sscalelip(fracinbuf)
4351          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4352         elseif (zj.gt.bufliptop) then
4353          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4354          sslipj=sscalelip(fracinbuf)
4355          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4356         else
4357          sslipj=1.0d0
4358          ssgradlipj=0.0
4359         endif
4360        else
4361          sslipj=0.0d0
4362          ssgradlipj=0.0
4363        endif
4364
4365       a_temp(1,1)=a22
4366       a_temp(1,2)=a23
4367       a_temp(2,1)=a32
4368       a_temp(2,2)=a33
4369 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4370 !
4371 !               Third-order contributions
4372 !
4373 !                 (i+2)o----(i+3)
4374 !                      | |
4375 !                      | |
4376 !                 (i+1)o----i
4377 !
4378 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4379 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4380         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4381         call transpose2(auxmat(1,1),auxmat1(1,1))
4382         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4383         if (shield_mode.eq.0) then
4384         fac_shield(i)=1.0d0
4385         fac_shield(j)=1.0d0
4386         endif
4387
4388         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4389          *fac_shield(i)*fac_shield(j)  &
4390          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4391         eello_t3= &
4392         0.5d0*(pizda(1,1)+pizda(2,2)) &
4393         *fac_shield(i)*fac_shield(j)
4394
4395         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4396                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4397           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4398        (shield_mode.gt.0)) then
4399 !C          print *,i,j
4400
4401           do ilist=1,ishield_list(i)
4402            iresshield=shield_list(ilist,i)
4403            do k=1,3
4404            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4405            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4406                    rlocshield &
4407            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4408             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4409              +rlocshield
4410            enddo
4411           enddo
4412           do ilist=1,ishield_list(j)
4413            iresshield=shield_list(ilist,j)
4414            do k=1,3
4415            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4416            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4417                    rlocshield &
4418            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4419            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4420                   +rlocshield
4421
4422            enddo
4423           enddo
4424
4425           do k=1,3
4426             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4427                    grad_shield(k,i)*eello_t3/fac_shield(i)
4428             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4429                    grad_shield(k,j)*eello_t3/fac_shield(j)
4430             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4431                    grad_shield(k,i)*eello_t3/fac_shield(i)
4432             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4433                    grad_shield(k,j)*eello_t3/fac_shield(j)
4434            enddo
4435            endif
4436
4437 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4438 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4439 !d     &    ' eello_turn3_num',4*eello_turn3_num
4440 ! Derivatives in gamma(i)
4441         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4442         call transpose2(auxmat2(1,1),auxmat3(1,1))
4443         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4444         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4445           *fac_shield(i)*fac_shield(j)        &
4446           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4447 ! Derivatives in gamma(i+1)
4448         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4449         call transpose2(auxmat2(1,1),auxmat3(1,1))
4450         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4451         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4452           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4453           *fac_shield(i)*fac_shield(j)        &
4454           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4455
4456 ! Cartesian derivatives
4457         do l=1,3
4458 !            ghalf1=0.5d0*agg(l,1)
4459 !            ghalf2=0.5d0*agg(l,2)
4460 !            ghalf3=0.5d0*agg(l,3)
4461 !            ghalf4=0.5d0*agg(l,4)
4462           a_temp(1,1)=aggi(l,1)!+ghalf1
4463           a_temp(1,2)=aggi(l,2)!+ghalf2
4464           a_temp(2,1)=aggi(l,3)!+ghalf3
4465           a_temp(2,2)=aggi(l,4)!+ghalf4
4466           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4467           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4468             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4469           *fac_shield(i)*fac_shield(j)      &
4470           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4471
4472           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4473           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4474           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4475           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4476           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4477           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4478             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4479           *fac_shield(i)*fac_shield(j)        &
4480           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4481
4482           a_temp(1,1)=aggj(l,1)!+ghalf1
4483           a_temp(1,2)=aggj(l,2)!+ghalf2
4484           a_temp(2,1)=aggj(l,3)!+ghalf3
4485           a_temp(2,2)=aggj(l,4)!+ghalf4
4486           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4487           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4488             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4489           *fac_shield(i)*fac_shield(j)      &
4490           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4491
4492           a_temp(1,1)=aggj1(l,1)
4493           a_temp(1,2)=aggj1(l,2)
4494           a_temp(2,1)=aggj1(l,3)
4495           a_temp(2,2)=aggj1(l,4)
4496           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4497           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4498             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4499           *fac_shield(i)*fac_shield(j)        &
4500           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4501         enddo
4502          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4503           ssgradlipi*eello_t3/4.0d0*lipscale
4504          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4505           ssgradlipj*eello_t3/4.0d0*lipscale
4506          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4507           ssgradlipi*eello_t3/4.0d0*lipscale
4508          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4509           ssgradlipj*eello_t3/4.0d0*lipscale
4510
4511       return
4512       end subroutine eturn3
4513 !-----------------------------------------------------------------------------
4514       subroutine eturn4(i,eello_turn4)
4515 ! Third- and fourth-order contributions from turns
4516
4517       use comm_locel
4518 !      implicit real*8 (a-h,o-z)
4519 !      include 'DIMENSIONS'
4520 !      include 'COMMON.IOUNITS'
4521 !      include 'COMMON.GEO'
4522 !      include 'COMMON.VAR'
4523 !      include 'COMMON.LOCAL'
4524 !      include 'COMMON.CHAIN'
4525 !      include 'COMMON.DERIV'
4526 !      include 'COMMON.INTERACT'
4527 !      include 'COMMON.CONTACTS'
4528 !      include 'COMMON.TORSION'
4529 !      include 'COMMON.VECTORS'
4530 !      include 'COMMON.FFIELD'
4531 !      include 'COMMON.CONTROL'
4532       real(kind=8),dimension(3) :: ggg
4533       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4534         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4535       real(kind=8),dimension(2) :: auxvec,auxvec1
4536 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4537       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4538 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4539 !el        dz_normi,xmedi,ymedi,zmedi
4540 !el      integer :: num_conti,j1,j2
4541 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4542 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4543 !el          num_conti,j1,j2
4544 !el local variables
4545       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4546       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4547          rlocshield
4548
4549       j=i+3
4550 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4551 !
4552 !               Fourth-order contributions
4553 !
4554 !                 (i+3)o----(i+4)
4555 !                     /  |
4556 !               (i+2)o   |
4557 !                     \  |
4558 !                 (i+1)o----i
4559 !
4560 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4561 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4562 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4563           zj=(c(3,j)+c(3,j+1))/2.0d0
4564           zj=mod(zj,boxzsize)
4565           if (zj.lt.0) zj=zj+boxzsize
4566        if ((zj.gt.bordlipbot)  &
4567         .and.(zj.lt.bordliptop)) then
4568 !C the energy transfer exist
4569         if (zj.lt.buflipbot) then
4570 !C what fraction I am in
4571          fracinbuf=1.0d0-     &
4572              ((zj-bordlipbot)/lipbufthick)
4573 !C lipbufthick is thickenes of lipid buffore
4574          sslipj=sscalelip(fracinbuf)
4575          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4576         elseif (zj.gt.bufliptop) then
4577          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4578          sslipj=sscalelip(fracinbuf)
4579          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4580         else
4581          sslipj=1.0d0
4582          ssgradlipj=0.0
4583         endif
4584        else
4585          sslipj=0.0d0
4586          ssgradlipj=0.0
4587        endif
4588
4589         a_temp(1,1)=a22
4590         a_temp(1,2)=a23
4591         a_temp(2,1)=a32
4592         a_temp(2,2)=a33
4593         iti1=itortyp(itype(i+1,1))
4594         iti2=itortyp(itype(i+2,1))
4595         iti3=itortyp(itype(i+3,1))
4596 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4597         call transpose2(EUg(1,1,i+1),e1t(1,1))
4598         call transpose2(Eug(1,1,i+2),e2t(1,1))
4599         call transpose2(Eug(1,1,i+3),e3t(1,1))
4600         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4601         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4602         s1=scalar2(b1(1,iti2),auxvec(1))
4603         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4604         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4605         s2=scalar2(b1(1,iti1),auxvec(1))
4606         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4607         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4608         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4609         if (shield_mode.eq.0) then
4610         fac_shield(i)=1.0
4611         fac_shield(j)=1.0
4612         endif
4613
4614         eello_turn4=eello_turn4-(s1+s2+s3) &
4615         *fac_shield(i)*fac_shield(j)       &
4616         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4617         eello_t4=-(s1+s2+s3)  &
4618           *fac_shield(i)*fac_shield(j)
4619 !C Now derivative over shield:
4620           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4621          (shield_mode.gt.0)) then
4622 !C          print *,i,j
4623
4624           do ilist=1,ishield_list(i)
4625            iresshield=shield_list(ilist,i)
4626            do k=1,3
4627            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4628            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4629                    rlocshield &
4630             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4631             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4632            +rlocshield
4633            enddo
4634           enddo
4635           do ilist=1,ishield_list(j)
4636            iresshield=shield_list(ilist,j)
4637            do k=1,3
4638            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4639            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4640                    rlocshield  &
4641            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4642            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4643                   +rlocshield
4644
4645            enddo
4646           enddo
4647
4648           do k=1,3
4649             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4650                    grad_shield(k,i)*eello_t4/fac_shield(i)
4651             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4652                    grad_shield(k,j)*eello_t4/fac_shield(j)
4653             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4654                    grad_shield(k,i)*eello_t4/fac_shield(i)
4655             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4656                    grad_shield(k,j)*eello_t4/fac_shield(j)
4657            enddo
4658            endif
4659
4660         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4661            'eturn4',i,j,-(s1+s2+s3)
4662 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4663 !d     &    ' eello_turn4_num',8*eello_turn4_num
4664 ! Derivatives in gamma(i)
4665         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4666         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4667         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4668         s1=scalar2(b1(1,iti2),auxvec(1))
4669         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4670         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4671         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4672        *fac_shield(i)*fac_shield(j)  &
4673        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4674
4675 ! Derivatives in gamma(i+1)
4676         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4677         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4678         s2=scalar2(b1(1,iti1),auxvec(1))
4679         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4680         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4681         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4682         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4683        *fac_shield(i)*fac_shield(j)  &
4684        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4685
4686 ! Derivatives in gamma(i+2)
4687         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4688         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4689         s1=scalar2(b1(1,iti2),auxvec(1))
4690         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4691         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4692         s2=scalar2(b1(1,iti1),auxvec(1))
4693         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4694         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4695         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4696         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4697        *fac_shield(i)*fac_shield(j)  &
4698        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4699
4700 ! Cartesian derivatives
4701 ! Derivatives of this turn contributions in DC(i+2)
4702         if (j.lt.nres-1) then
4703           do l=1,3
4704             a_temp(1,1)=agg(l,1)
4705             a_temp(1,2)=agg(l,2)
4706             a_temp(2,1)=agg(l,3)
4707             a_temp(2,2)=agg(l,4)
4708             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4709             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4710             s1=scalar2(b1(1,iti2),auxvec(1))
4711             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4712             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4713             s2=scalar2(b1(1,iti1),auxvec(1))
4714             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4715             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4716             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4717             ggg(l)=-(s1+s2+s3)
4718             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4719        *fac_shield(i)*fac_shield(j)  &
4720        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4721
4722           enddo
4723         endif
4724 ! Remaining derivatives of this turn contribution
4725         do l=1,3
4726           a_temp(1,1)=aggi(l,1)
4727           a_temp(1,2)=aggi(l,2)
4728           a_temp(2,1)=aggi(l,3)
4729           a_temp(2,2)=aggi(l,4)
4730           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4731           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4732           s1=scalar2(b1(1,iti2),auxvec(1))
4733           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4734           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4735           s2=scalar2(b1(1,iti1),auxvec(1))
4736           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4737           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4738           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4739           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4740          *fac_shield(i)*fac_shield(j)  &
4741          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4742
4743
4744           a_temp(1,1)=aggi1(l,1)
4745           a_temp(1,2)=aggi1(l,2)
4746           a_temp(2,1)=aggi1(l,3)
4747           a_temp(2,2)=aggi1(l,4)
4748           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4749           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4750           s1=scalar2(b1(1,iti2),auxvec(1))
4751           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4752           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4753           s2=scalar2(b1(1,iti1),auxvec(1))
4754           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4755           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4756           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4757           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4758          *fac_shield(i)*fac_shield(j)  &
4759          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4760
4761
4762           a_temp(1,1)=aggj(l,1)
4763           a_temp(1,2)=aggj(l,2)
4764           a_temp(2,1)=aggj(l,3)
4765           a_temp(2,2)=aggj(l,4)
4766           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4767           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4768           s1=scalar2(b1(1,iti2),auxvec(1))
4769           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4770           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4771           s2=scalar2(b1(1,iti1),auxvec(1))
4772           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4773           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4774           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4775           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4776          *fac_shield(i)*fac_shield(j)  &
4777          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4778
4779
4780           a_temp(1,1)=aggj1(l,1)
4781           a_temp(1,2)=aggj1(l,2)
4782           a_temp(2,1)=aggj1(l,3)
4783           a_temp(2,2)=aggj1(l,4)
4784           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4785           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4786           s1=scalar2(b1(1,iti2),auxvec(1))
4787           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4788           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4789           s2=scalar2(b1(1,iti1),auxvec(1))
4790           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4791           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4792           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4793 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4794           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4795          *fac_shield(i)*fac_shield(j)  &
4796          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4797
4798         enddo
4799          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4800           ssgradlipi*eello_t4/4.0d0*lipscale
4801          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4802           ssgradlipj*eello_t4/4.0d0*lipscale
4803          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4804           ssgradlipi*eello_t4/4.0d0*lipscale
4805          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4806           ssgradlipj*eello_t4/4.0d0*lipscale
4807
4808       return
4809       end subroutine eturn4
4810 !-----------------------------------------------------------------------------
4811       subroutine unormderiv(u,ugrad,unorm,ungrad)
4812 ! This subroutine computes the derivatives of a normalized vector u, given
4813 ! the derivatives computed without normalization conditions, ugrad. Returns
4814 ! ungrad.
4815 !      implicit none
4816       real(kind=8),dimension(3) :: u,vec
4817       real(kind=8),dimension(3,3) ::ugrad,ungrad
4818       real(kind=8) :: unorm      !,scalar
4819       integer :: i,j
4820 !      write (2,*) 'ugrad',ugrad
4821 !      write (2,*) 'u',u
4822       do i=1,3
4823         vec(i)=scalar(ugrad(1,i),u(1))
4824       enddo
4825 !      write (2,*) 'vec',vec
4826       do i=1,3
4827         do j=1,3
4828           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4829         enddo
4830       enddo
4831 !      write (2,*) 'ungrad',ungrad
4832       return
4833       end subroutine unormderiv
4834 !-----------------------------------------------------------------------------
4835       subroutine escp_soft_sphere(evdw2,evdw2_14)
4836 !
4837 ! This subroutine calculates the excluded-volume interaction energy between
4838 ! peptide-group centers and side chains and its gradient in virtual-bond and
4839 ! side-chain vectors.
4840 !
4841 !      implicit real*8 (a-h,o-z)
4842 !      include 'DIMENSIONS'
4843 !      include 'COMMON.GEO'
4844 !      include 'COMMON.VAR'
4845 !      include 'COMMON.LOCAL'
4846 !      include 'COMMON.CHAIN'
4847 !      include 'COMMON.DERIV'
4848 !      include 'COMMON.INTERACT'
4849 !      include 'COMMON.FFIELD'
4850 !      include 'COMMON.IOUNITS'
4851 !      include 'COMMON.CONTROL'
4852       real(kind=8),dimension(3) :: ggg
4853 !el local variables
4854       integer :: i,iint,j,k,iteli,itypj
4855       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4856                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4857
4858       evdw2=0.0D0
4859       evdw2_14=0.0d0
4860       r0_scp=4.5d0
4861 !d    print '(a)','Enter ESCP'
4862 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4863       do i=iatscp_s,iatscp_e
4864         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4865         iteli=itel(i)
4866         xi=0.5D0*(c(1,i)+c(1,i+1))
4867         yi=0.5D0*(c(2,i)+c(2,i+1))
4868         zi=0.5D0*(c(3,i)+c(3,i+1))
4869
4870         do iint=1,nscp_gr(i)
4871
4872         do j=iscpstart(i,iint),iscpend(i,iint)
4873           if (itype(j,1).eq.ntyp1) cycle
4874           itypj=iabs(itype(j,1))
4875 ! Uncomment following three lines for SC-p interactions
4876 !         xj=c(1,nres+j)-xi
4877 !         yj=c(2,nres+j)-yi
4878 !         zj=c(3,nres+j)-zi
4879 ! Uncomment following three lines for Ca-p interactions
4880           xj=c(1,j)-xi
4881           yj=c(2,j)-yi
4882           zj=c(3,j)-zi
4883           rij=xj*xj+yj*yj+zj*zj
4884           r0ij=r0_scp
4885           r0ijsq=r0ij*r0ij
4886           if (rij.lt.r0ijsq) then
4887             evdwij=0.25d0*(rij-r0ijsq)**2
4888             fac=rij-r0ijsq
4889           else
4890             evdwij=0.0d0
4891             fac=0.0d0
4892           endif
4893           evdw2=evdw2+evdwij
4894 !
4895 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4896 !
4897           ggg(1)=xj*fac
4898           ggg(2)=yj*fac
4899           ggg(3)=zj*fac
4900 !grad          if (j.lt.i) then
4901 !d          write (iout,*) 'j<i'
4902 ! Uncomment following three lines for SC-p interactions
4903 !           do k=1,3
4904 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4905 !           enddo
4906 !grad          else
4907 !d          write (iout,*) 'j>i'
4908 !grad            do k=1,3
4909 !grad              ggg(k)=-ggg(k)
4910 ! Uncomment following line for SC-p interactions
4911 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4912 !grad            enddo
4913 !grad          endif
4914 !grad          do k=1,3
4915 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4916 !grad          enddo
4917 !grad          kstart=min0(i+1,j)
4918 !grad          kend=max0(i-1,j-1)
4919 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4920 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4921 !grad          do k=kstart,kend
4922 !grad            do l=1,3
4923 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4924 !grad            enddo
4925 !grad          enddo
4926           do k=1,3
4927             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4928             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4929           enddo
4930         enddo
4931
4932         enddo ! iint
4933       enddo ! i
4934       return
4935       end subroutine escp_soft_sphere
4936 !-----------------------------------------------------------------------------
4937       subroutine escp(evdw2,evdw2_14)
4938 !
4939 ! This subroutine calculates the excluded-volume interaction energy between
4940 ! peptide-group centers and side chains and its gradient in virtual-bond and
4941 ! side-chain vectors.
4942 !
4943 !      implicit real*8 (a-h,o-z)
4944 !      include 'DIMENSIONS'
4945 !      include 'COMMON.GEO'
4946 !      include 'COMMON.VAR'
4947 !      include 'COMMON.LOCAL'
4948 !      include 'COMMON.CHAIN'
4949 !      include 'COMMON.DERIV'
4950 !      include 'COMMON.INTERACT'
4951 !      include 'COMMON.FFIELD'
4952 !      include 'COMMON.IOUNITS'
4953 !      include 'COMMON.CONTROL'
4954       real(kind=8),dimension(3) :: ggg
4955 !el local variables
4956       integer :: i,iint,j,k,iteli,itypj,subchap
4957       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4958                    e1,e2,evdwij,rij
4959       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4960                     dist_temp, dist_init
4961       integer xshift,yshift,zshift
4962
4963       evdw2=0.0D0
4964       evdw2_14=0.0d0
4965 !d    print '(a)','Enter ESCP'
4966 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4967       do i=iatscp_s,iatscp_e
4968         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4969         iteli=itel(i)
4970         xi=0.5D0*(c(1,i)+c(1,i+1))
4971         yi=0.5D0*(c(2,i)+c(2,i+1))
4972         zi=0.5D0*(c(3,i)+c(3,i+1))
4973           xi=mod(xi,boxxsize)
4974           if (xi.lt.0) xi=xi+boxxsize
4975           yi=mod(yi,boxysize)
4976           if (yi.lt.0) yi=yi+boxysize
4977           zi=mod(zi,boxzsize)
4978           if (zi.lt.0) zi=zi+boxzsize
4979
4980         do iint=1,nscp_gr(i)
4981
4982         do j=iscpstart(i,iint),iscpend(i,iint)
4983           itypj=iabs(itype(j,1))
4984           if (itypj.eq.ntyp1) cycle
4985 ! Uncomment following three lines for SC-p interactions
4986 !         xj=c(1,nres+j)-xi
4987 !         yj=c(2,nres+j)-yi
4988 !         zj=c(3,nres+j)-zi
4989 ! Uncomment following three lines for Ca-p interactions
4990 !          xj=c(1,j)-xi
4991 !          yj=c(2,j)-yi
4992 !          zj=c(3,j)-zi
4993           xj=c(1,j)
4994           yj=c(2,j)
4995           zj=c(3,j)
4996           xj=mod(xj,boxxsize)
4997           if (xj.lt.0) xj=xj+boxxsize
4998           yj=mod(yj,boxysize)
4999           if (yj.lt.0) yj=yj+boxysize
5000           zj=mod(zj,boxzsize)
5001           if (zj.lt.0) zj=zj+boxzsize
5002       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5003       xj_safe=xj
5004       yj_safe=yj
5005       zj_safe=zj
5006       subchap=0
5007       do xshift=-1,1
5008       do yshift=-1,1
5009       do zshift=-1,1
5010           xj=xj_safe+xshift*boxxsize
5011           yj=yj_safe+yshift*boxysize
5012           zj=zj_safe+zshift*boxzsize
5013           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5014           if(dist_temp.lt.dist_init) then
5015             dist_init=dist_temp
5016             xj_temp=xj
5017             yj_temp=yj
5018             zj_temp=zj
5019             subchap=1
5020           endif
5021        enddo
5022        enddo
5023        enddo
5024        if (subchap.eq.1) then
5025           xj=xj_temp-xi
5026           yj=yj_temp-yi
5027           zj=zj_temp-zi
5028        else
5029           xj=xj_safe-xi
5030           yj=yj_safe-yi
5031           zj=zj_safe-zi
5032        endif
5033
5034           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5035           rij=dsqrt(1.0d0/rrij)
5036             sss_ele_cut=sscale_ele(rij)
5037             sss_ele_grad=sscagrad_ele(rij)
5038 !            print *,sss_ele_cut,sss_ele_grad,&
5039 !            (rij),r_cut_ele,rlamb_ele
5040             if (sss_ele_cut.le.0.0) cycle
5041           fac=rrij**expon2
5042           e1=fac*fac*aad(itypj,iteli)
5043           e2=fac*bad(itypj,iteli)
5044           if (iabs(j-i) .le. 2) then
5045             e1=scal14*e1
5046             e2=scal14*e2
5047             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5048           endif
5049           evdwij=e1+e2
5050           evdw2=evdw2+evdwij*sss_ele_cut
5051 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5052 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5053           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5054              'evdw2',i,j,evdwij
5055 !
5056 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5057 !
5058           fac=-(evdwij+e1)*rrij*sss_ele_cut
5059           fac=fac+evdwij*sss_ele_grad/rij/expon
5060           ggg(1)=xj*fac
5061           ggg(2)=yj*fac
5062           ggg(3)=zj*fac
5063 !grad          if (j.lt.i) then
5064 !d          write (iout,*) 'j<i'
5065 ! Uncomment following three lines for SC-p interactions
5066 !           do k=1,3
5067 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5068 !           enddo
5069 !grad          else
5070 !d          write (iout,*) 'j>i'
5071 !grad            do k=1,3
5072 !grad              ggg(k)=-ggg(k)
5073 ! Uncomment following line for SC-p interactions
5074 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5075 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5076 !grad            enddo
5077 !grad          endif
5078 !grad          do k=1,3
5079 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5080 !grad          enddo
5081 !grad          kstart=min0(i+1,j)
5082 !grad          kend=max0(i-1,j-1)
5083 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5084 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5085 !grad          do k=kstart,kend
5086 !grad            do l=1,3
5087 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5088 !grad            enddo
5089 !grad          enddo
5090           do k=1,3
5091             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5092             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5093           enddo
5094         enddo
5095
5096         enddo ! iint
5097       enddo ! i
5098       do i=1,nct
5099         do j=1,3
5100           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5101           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5102           gradx_scp(j,i)=expon*gradx_scp(j,i)
5103         enddo
5104       enddo
5105 !******************************************************************************
5106 !
5107 !                              N O T E !!!
5108 !
5109 ! To save time the factor EXPON has been extracted from ALL components
5110 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5111 ! use!
5112 !
5113 !******************************************************************************
5114       return
5115       end subroutine escp
5116 !-----------------------------------------------------------------------------
5117       subroutine edis(ehpb)
5118 !
5119 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5120 !
5121 !      implicit real*8 (a-h,o-z)
5122 !      include 'DIMENSIONS'
5123 !      include 'COMMON.SBRIDGE'
5124 !      include 'COMMON.CHAIN'
5125 !      include 'COMMON.DERIV'
5126 !      include 'COMMON.VAR'
5127 !      include 'COMMON.INTERACT'
5128 !      include 'COMMON.IOUNITS'
5129       real(kind=8),dimension(3) :: ggg
5130 !el local variables
5131       integer :: i,j,ii,jj,iii,jjj,k
5132       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5133
5134       ehpb=0.0D0
5135 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5136 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5137       if (link_end.eq.0) return
5138       do i=link_start,link_end
5139 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5140 ! CA-CA distance used in regularization of structure.
5141         ii=ihpb(i)
5142         jj=jhpb(i)
5143 ! iii and jjj point to the residues for which the distance is assigned.
5144         if (ii.gt.nres) then
5145           iii=ii-nres
5146           jjj=jj-nres
5147         else
5148           iii=ii
5149           jjj=jj
5150         endif
5151 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5152 !     &    dhpb(i),dhpb1(i),forcon(i)
5153 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5154 !    distance and angle dependent SS bond potential.
5155 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5156 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5157         if (.not.dyn_ss .and. i.le.nss) then
5158 ! 15/02/13 CC dynamic SSbond - additional check
5159          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5160         iabs(itype(jjj,1)).eq.1) then
5161           call ssbond_ene(iii,jjj,eij)
5162           ehpb=ehpb+2*eij
5163 !d          write (iout,*) "eij",eij
5164          endif
5165         else if (ii.gt.nres .and. jj.gt.nres) then
5166 !c Restraints from contact prediction
5167           dd=dist(ii,jj)
5168           if (constr_dist.eq.11) then
5169             ehpb=ehpb+fordepth(i)**4.0d0 &
5170                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5171             fac=fordepth(i)**4.0d0 &
5172                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5173           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5174             ehpb,fordepth(i),dd
5175            else
5176           if (dhpb1(i).gt.0.0d0) then
5177             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5178             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5179 !c            write (iout,*) "beta nmr",
5180 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5181           else
5182             dd=dist(ii,jj)
5183             rdis=dd-dhpb(i)
5184 !C Get the force constant corresponding to this distance.
5185             waga=forcon(i)
5186 !C Calculate the contribution to energy.
5187             ehpb=ehpb+waga*rdis*rdis
5188 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5189 !C
5190 !C Evaluate gradient.
5191 !C
5192             fac=waga*rdis/dd
5193           endif
5194           endif
5195           do j=1,3
5196             ggg(j)=fac*(c(j,jj)-c(j,ii))
5197           enddo
5198           do j=1,3
5199             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5200             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5201           enddo
5202           do k=1,3
5203             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5204             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5205           enddo
5206         else
5207           dd=dist(ii,jj)
5208           if (constr_dist.eq.11) then
5209             ehpb=ehpb+fordepth(i)**4.0d0 &
5210                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5211             fac=fordepth(i)**4.0d0 &
5212                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5213           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5214          ehpb,fordepth(i),dd
5215            else
5216           if (dhpb1(i).gt.0.0d0) then
5217             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5218             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5219 !c            write (iout,*) "alph nmr",
5220 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5221           else
5222             rdis=dd-dhpb(i)
5223 !C Get the force constant corresponding to this distance.
5224             waga=forcon(i)
5225 !C Calculate the contribution to energy.
5226             ehpb=ehpb+waga*rdis*rdis
5227 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5228 !C
5229 !C Evaluate gradient.
5230 !C
5231             fac=waga*rdis/dd
5232           endif
5233           endif
5234
5235             do j=1,3
5236               ggg(j)=fac*(c(j,jj)-c(j,ii))
5237             enddo
5238 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5239 !C If this is a SC-SC distance, we need to calculate the contributions to the
5240 !C Cartesian gradient in the SC vectors (ghpbx).
5241           if (iii.lt.ii) then
5242           do j=1,3
5243             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5244             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5245           enddo
5246           endif
5247 !cgrad        do j=iii,jjj-1
5248 !cgrad          do k=1,3
5249 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5250 !cgrad          enddo
5251 !cgrad        enddo
5252           do k=1,3
5253             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5254             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5255           enddo
5256         endif
5257       enddo
5258       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5259
5260       return
5261       end subroutine edis
5262 !-----------------------------------------------------------------------------
5263       subroutine ssbond_ene(i,j,eij)
5264 !
5265 ! Calculate the distance and angle dependent SS-bond potential energy
5266 ! using a free-energy function derived based on RHF/6-31G** ab initio
5267 ! calculations of diethyl disulfide.
5268 !
5269 ! A. Liwo and U. Kozlowska, 11/24/03
5270 !
5271 !      implicit real*8 (a-h,o-z)
5272 !      include 'DIMENSIONS'
5273 !      include 'COMMON.SBRIDGE'
5274 !      include 'COMMON.CHAIN'
5275 !      include 'COMMON.DERIV'
5276 !      include 'COMMON.LOCAL'
5277 !      include 'COMMON.INTERACT'
5278 !      include 'COMMON.VAR'
5279 !      include 'COMMON.IOUNITS'
5280       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5281 !el local variables
5282       integer :: i,j,itypi,itypj,k
5283       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5284                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5285                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5286                    cosphi,ggk
5287
5288       itypi=iabs(itype(i,1))
5289       xi=c(1,nres+i)
5290       yi=c(2,nres+i)
5291       zi=c(3,nres+i)
5292       dxi=dc_norm(1,nres+i)
5293       dyi=dc_norm(2,nres+i)
5294       dzi=dc_norm(3,nres+i)
5295 !      dsci_inv=dsc_inv(itypi)
5296       dsci_inv=vbld_inv(nres+i)
5297       itypj=iabs(itype(j,1))
5298 !      dscj_inv=dsc_inv(itypj)
5299       dscj_inv=vbld_inv(nres+j)
5300       xj=c(1,nres+j)-xi
5301       yj=c(2,nres+j)-yi
5302       zj=c(3,nres+j)-zi
5303       dxj=dc_norm(1,nres+j)
5304       dyj=dc_norm(2,nres+j)
5305       dzj=dc_norm(3,nres+j)
5306       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5307       rij=dsqrt(rrij)
5308       erij(1)=xj*rij
5309       erij(2)=yj*rij
5310       erij(3)=zj*rij
5311       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5312       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5313       om12=dxi*dxj+dyi*dyj+dzi*dzj
5314       do k=1,3
5315         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5316         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5317       enddo
5318       rij=1.0d0/rij
5319       deltad=rij-d0cm
5320       deltat1=1.0d0-om1
5321       deltat2=1.0d0+om2
5322       deltat12=om2-om1+2.0d0
5323       cosphi=om12-om1*om2
5324       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5325         +akct*deltad*deltat12 &
5326         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5327 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5328 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5329 !     &  " deltat12",deltat12," eij",eij
5330       ed=2*akcm*deltad+akct*deltat12
5331       pom1=akct*deltad
5332       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5333       eom1=-2*akth*deltat1-pom1-om2*pom2
5334       eom2= 2*akth*deltat2+pom1-om1*pom2
5335       eom12=pom2
5336       do k=1,3
5337         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5338         ghpbx(k,i)=ghpbx(k,i)-ggk &
5339                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5340                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5341         ghpbx(k,j)=ghpbx(k,j)+ggk &
5342                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5343                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5344         ghpbc(k,i)=ghpbc(k,i)-ggk
5345         ghpbc(k,j)=ghpbc(k,j)+ggk
5346       enddo
5347 !
5348 ! Calculate the components of the gradient in DC and X
5349 !
5350 !grad      do k=i,j-1
5351 !grad        do l=1,3
5352 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5353 !grad        enddo
5354 !grad      enddo
5355       return
5356       end subroutine ssbond_ene
5357 !-----------------------------------------------------------------------------
5358       subroutine ebond(estr)
5359 !
5360 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5361 !
5362 !      implicit real*8 (a-h,o-z)
5363 !      include 'DIMENSIONS'
5364 !      include 'COMMON.LOCAL'
5365 !      include 'COMMON.GEO'
5366 !      include 'COMMON.INTERACT'
5367 !      include 'COMMON.DERIV'
5368 !      include 'COMMON.VAR'
5369 !      include 'COMMON.CHAIN'
5370 !      include 'COMMON.IOUNITS'
5371 !      include 'COMMON.NAMES'
5372 !      include 'COMMON.FFIELD'
5373 !      include 'COMMON.CONTROL'
5374 !      include 'COMMON.SETUP'
5375       real(kind=8),dimension(3) :: u,ud
5376 !el local variables
5377       integer :: i,j,iti,nbi,k
5378       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5379                    uprod1,uprod2
5380
5381       estr=0.0d0
5382       estr1=0.0d0
5383 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5384 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5385
5386       do i=ibondp_start,ibondp_end
5387         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5388         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5389 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5390 !C          do j=1,3
5391 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5392 !C            *dc(j,i-1)/vbld(i)
5393 !C          enddo
5394 !C          if (energy_dec) write(iout,*) &
5395 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5396         diff = vbld(i)-vbldpDUM
5397         else
5398         diff = vbld(i)-vbldp0
5399         endif
5400         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5401            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5402         estr=estr+diff*diff
5403         do j=1,3
5404           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5405         enddo
5406 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5407 !        endif
5408       enddo
5409       estr=0.5d0*AKP*estr+estr1
5410 !      print *,"estr_bb",estr,AKP
5411 !
5412 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5413 !
5414       do i=ibond_start,ibond_end
5415         iti=iabs(itype(i,1))
5416         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5417         if (iti.ne.10 .and. iti.ne.ntyp1) then
5418           nbi=nbondterm(iti)
5419           if (nbi.eq.1) then
5420             diff=vbld(i+nres)-vbldsc0(1,iti)
5421             if (energy_dec) write (iout,*) &
5422             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5423             AKSC(1,iti),AKSC(1,iti)*diff*diff
5424             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5425 !            print *,"estr_sc",estr
5426             do j=1,3
5427               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5428             enddo
5429           else
5430             do j=1,nbi
5431               diff=vbld(i+nres)-vbldsc0(j,iti)
5432               ud(j)=aksc(j,iti)*diff
5433               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5434             enddo
5435             uprod=u(1)
5436             do j=2,nbi
5437               uprod=uprod*u(j)
5438             enddo
5439             usum=0.0d0
5440             usumsqder=0.0d0
5441             do j=1,nbi
5442               uprod1=1.0d0
5443               uprod2=1.0d0
5444               do k=1,nbi
5445                 if (k.ne.j) then
5446                   uprod1=uprod1*u(k)
5447                   uprod2=uprod2*u(k)*u(k)
5448                 endif
5449               enddo
5450               usum=usum+uprod1
5451               usumsqder=usumsqder+ud(j)*uprod2
5452             enddo
5453             estr=estr+uprod/usum
5454 !            print *,"estr_sc",estr,i
5455
5456              if (energy_dec) write (iout,*) &
5457             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5458             AKSC(1,iti),uprod/usum
5459             do j=1,3
5460              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5461             enddo
5462           endif
5463         endif
5464       enddo
5465       return
5466       end subroutine ebond
5467 #ifdef CRYST_THETA
5468 !-----------------------------------------------------------------------------
5469       subroutine ebend(etheta)
5470 !
5471 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5472 ! angles gamma and its derivatives in consecutive thetas and gammas.
5473 !
5474       use comm_calcthet
5475 !      implicit real*8 (a-h,o-z)
5476 !      include 'DIMENSIONS'
5477 !      include 'COMMON.LOCAL'
5478 !      include 'COMMON.GEO'
5479 !      include 'COMMON.INTERACT'
5480 !      include 'COMMON.DERIV'
5481 !      include 'COMMON.VAR'
5482 !      include 'COMMON.CHAIN'
5483 !      include 'COMMON.IOUNITS'
5484 !      include 'COMMON.NAMES'
5485 !      include 'COMMON.FFIELD'
5486 !      include 'COMMON.CONTROL'
5487 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5488 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5489 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5490 !el      integer :: it
5491 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5492 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5493 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5494 !el local variables
5495       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5496        ichir21,ichir22
5497       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5498        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5499        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5500       real(kind=8),dimension(2) :: y,z
5501
5502       delta=0.02d0*pi
5503 !      time11=dexp(-2*time)
5504 !      time12=1.0d0
5505       etheta=0.0D0
5506 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5507       do i=ithet_start,ithet_end
5508         if (itype(i-1,1).eq.ntyp1) cycle
5509 ! Zero the energy function and its derivative at 0 or pi.
5510         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5511         it=itype(i-1,1)
5512         ichir1=isign(1,itype(i-2,1))
5513         ichir2=isign(1,itype(i,1))
5514          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5515          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5516          if (itype(i-1,1).eq.10) then
5517           itype1=isign(10,itype(i-2,1))
5518           ichir11=isign(1,itype(i-2,1))
5519           ichir12=isign(1,itype(i-2,1))
5520           itype2=isign(10,itype(i,1))
5521           ichir21=isign(1,itype(i,1))
5522           ichir22=isign(1,itype(i,1))
5523          endif
5524
5525         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5526 #ifdef OSF
5527           phii=phi(i)
5528           if (phii.ne.phii) phii=150.0
5529 #else
5530           phii=phi(i)
5531 #endif
5532           y(1)=dcos(phii)
5533           y(2)=dsin(phii)
5534         else
5535           y(1)=0.0D0
5536           y(2)=0.0D0
5537         endif
5538         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5539 #ifdef OSF
5540           phii1=phi(i+1)
5541           if (phii1.ne.phii1) phii1=150.0
5542           phii1=pinorm(phii1)
5543           z(1)=cos(phii1)
5544 #else
5545           phii1=phi(i+1)
5546           z(1)=dcos(phii1)
5547 #endif
5548           z(2)=dsin(phii1)
5549         else
5550           z(1)=0.0D0
5551           z(2)=0.0D0
5552         endif
5553 ! Calculate the "mean" value of theta from the part of the distribution
5554 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5555 ! In following comments this theta will be referred to as t_c.
5556         thet_pred_mean=0.0d0
5557         do k=1,2
5558             athetk=athet(k,it,ichir1,ichir2)
5559             bthetk=bthet(k,it,ichir1,ichir2)
5560           if (it.eq.10) then
5561              athetk=athet(k,itype1,ichir11,ichir12)
5562              bthetk=bthet(k,itype2,ichir21,ichir22)
5563           endif
5564          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5565         enddo
5566         dthett=thet_pred_mean*ssd
5567         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5568 ! Derivatives of the "mean" values in gamma1 and gamma2.
5569         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5570                +athet(2,it,ichir1,ichir2)*y(1))*ss
5571         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5572                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5573          if (it.eq.10) then
5574         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5575              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5576         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5577                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5578          endif
5579         if (theta(i).gt.pi-delta) then
5580           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5581                E_tc0)
5582           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5583           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5584           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5585               E_theta)
5586           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5587               E_tc)
5588         else if (theta(i).lt.delta) then
5589           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5590           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5591           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5592               E_theta)
5593           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5594           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5595               E_tc)
5596         else
5597           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5598               E_theta,E_tc)
5599         endif
5600         etheta=etheta+ethetai
5601         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5602             'ebend',i,ethetai
5603         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5604         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5605         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5606       enddo
5607 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5608
5609 ! Ufff.... We've done all this!!!
5610       return
5611       end subroutine ebend
5612 !-----------------------------------------------------------------------------
5613       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5614
5615       use comm_calcthet
5616 !      implicit real*8 (a-h,o-z)
5617 !      include 'DIMENSIONS'
5618 !      include 'COMMON.LOCAL'
5619 !      include 'COMMON.IOUNITS'
5620 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5621 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5622 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5623       integer :: i,j,k
5624       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5625 !el      integer :: it
5626 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5627 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5628 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5629 !el local variables
5630       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5631        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5632
5633 ! Calculate the contributions to both Gaussian lobes.
5634 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5635 ! The "polynomial part" of the "standard deviation" of this part of
5636 ! the distribution.
5637         sig=polthet(3,it)
5638         do j=2,0,-1
5639           sig=sig*thet_pred_mean+polthet(j,it)
5640         enddo
5641 ! Derivative of the "interior part" of the "standard deviation of the"
5642 ! gamma-dependent Gaussian lobe in t_c.
5643         sigtc=3*polthet(3,it)
5644         do j=2,1,-1
5645           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5646         enddo
5647         sigtc=sig*sigtc
5648 ! Set the parameters of both Gaussian lobes of the distribution.
5649 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5650         fac=sig*sig+sigc0(it)
5651         sigcsq=fac+fac
5652         sigc=1.0D0/sigcsq
5653 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5654         sigsqtc=-4.0D0*sigcsq*sigtc
5655 !       print *,i,sig,sigtc,sigsqtc
5656 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5657         sigtc=-sigtc/(fac*fac)
5658 ! Following variable is sigma(t_c)**(-2)
5659         sigcsq=sigcsq*sigcsq
5660         sig0i=sig0(it)
5661         sig0inv=1.0D0/sig0i**2
5662         delthec=thetai-thet_pred_mean
5663         delthe0=thetai-theta0i
5664         term1=-0.5D0*sigcsq*delthec*delthec
5665         term2=-0.5D0*sig0inv*delthe0*delthe0
5666 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5667 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5668 ! to the energy (this being the log of the distribution) at the end of energy
5669 ! term evaluation for this virtual-bond angle.
5670         if (term1.gt.term2) then
5671           termm=term1
5672           term2=dexp(term2-termm)
5673           term1=1.0d0
5674         else
5675           termm=term2
5676           term1=dexp(term1-termm)
5677           term2=1.0d0
5678         endif
5679 ! The ratio between the gamma-independent and gamma-dependent lobes of
5680 ! the distribution is a Gaussian function of thet_pred_mean too.
5681         diffak=gthet(2,it)-thet_pred_mean
5682         ratak=diffak/gthet(3,it)**2
5683         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5684 ! Let's differentiate it in thet_pred_mean NOW.
5685         aktc=ak*ratak
5686 ! Now put together the distribution terms to make complete distribution.
5687         termexp=term1+ak*term2
5688         termpre=sigc+ak*sig0i
5689 ! Contribution of the bending energy from this theta is just the -log of
5690 ! the sum of the contributions from the two lobes and the pre-exponential
5691 ! factor. Simple enough, isn't it?
5692         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5693 ! NOW the derivatives!!!
5694 ! 6/6/97 Take into account the deformation.
5695         E_theta=(delthec*sigcsq*term1 &
5696              +ak*delthe0*sig0inv*term2)/termexp
5697         E_tc=((sigtc+aktc*sig0i)/termpre &
5698             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5699              aktc*term2)/termexp)
5700       return
5701       end subroutine theteng
5702 #else
5703 !-----------------------------------------------------------------------------
5704       subroutine ebend(etheta,ethetacnstr)
5705 !
5706 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5707 ! angles gamma and its derivatives in consecutive thetas and gammas.
5708 ! ab initio-derived potentials from
5709 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5710 !
5711 !      implicit real*8 (a-h,o-z)
5712 !      include 'DIMENSIONS'
5713 !      include 'COMMON.LOCAL'
5714 !      include 'COMMON.GEO'
5715 !      include 'COMMON.INTERACT'
5716 !      include 'COMMON.DERIV'
5717 !      include 'COMMON.VAR'
5718 !      include 'COMMON.CHAIN'
5719 !      include 'COMMON.IOUNITS'
5720 !      include 'COMMON.NAMES'
5721 !      include 'COMMON.FFIELD'
5722 !      include 'COMMON.CONTROL'
5723       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5724       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5725       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5726       logical :: lprn=.false., lprn1=.false.
5727 !el local variables
5728       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5729       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5730       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5731 ! local variables for constrains
5732       real(kind=8) :: difi,thetiii
5733        integer itheta
5734
5735       etheta=0.0D0
5736       do i=ithet_start,ithet_end
5737         if (itype(i-1,1).eq.ntyp1) cycle
5738         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5739         if (iabs(itype(i+1,1)).eq.20) iblock=2
5740         if (iabs(itype(i+1,1)).ne.20) iblock=1
5741         dethetai=0.0d0
5742         dephii=0.0d0
5743         dephii1=0.0d0
5744         theti2=0.5d0*theta(i)
5745         ityp2=ithetyp((itype(i-1,1)))
5746         do k=1,nntheterm
5747           coskt(k)=dcos(k*theti2)
5748           sinkt(k)=dsin(k*theti2)
5749         enddo
5750         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5751 #ifdef OSF
5752           phii=phi(i)
5753           if (phii.ne.phii) phii=150.0
5754 #else
5755           phii=phi(i)
5756 #endif
5757           ityp1=ithetyp((itype(i-2,1)))
5758 ! propagation of chirality for glycine type
5759           do k=1,nsingle
5760             cosph1(k)=dcos(k*phii)
5761             sinph1(k)=dsin(k*phii)
5762           enddo
5763         else
5764           phii=0.0d0
5765           ityp1=ithetyp(itype(i-2,1))
5766           do k=1,nsingle
5767             cosph1(k)=0.0d0
5768             sinph1(k)=0.0d0
5769           enddo
5770         endif
5771         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5772 #ifdef OSF
5773           phii1=phi(i+1)
5774           if (phii1.ne.phii1) phii1=150.0
5775           phii1=pinorm(phii1)
5776 #else
5777           phii1=phi(i+1)
5778 #endif
5779           ityp3=ithetyp((itype(i,1)))
5780           do k=1,nsingle
5781             cosph2(k)=dcos(k*phii1)
5782             sinph2(k)=dsin(k*phii1)
5783           enddo
5784         else
5785           phii1=0.0d0
5786           ityp3=ithetyp(itype(i,1))
5787           do k=1,nsingle
5788             cosph2(k)=0.0d0
5789             sinph2(k)=0.0d0
5790           enddo
5791         endif
5792         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5793         do k=1,ndouble
5794           do l=1,k-1
5795             ccl=cosph1(l)*cosph2(k-l)
5796             ssl=sinph1(l)*sinph2(k-l)
5797             scl=sinph1(l)*cosph2(k-l)
5798             csl=cosph1(l)*sinph2(k-l)
5799             cosph1ph2(l,k)=ccl-ssl
5800             cosph1ph2(k,l)=ccl+ssl
5801             sinph1ph2(l,k)=scl+csl
5802             sinph1ph2(k,l)=scl-csl
5803           enddo
5804         enddo
5805         if (lprn) then
5806         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5807           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5808         write (iout,*) "coskt and sinkt"
5809         do k=1,nntheterm
5810           write (iout,*) k,coskt(k),sinkt(k)
5811         enddo
5812         endif
5813         do k=1,ntheterm
5814           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5815           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5816             *coskt(k)
5817           if (lprn) &
5818           write (iout,*) "k",k,&
5819            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5820            " ethetai",ethetai
5821         enddo
5822         if (lprn) then
5823         write (iout,*) "cosph and sinph"
5824         do k=1,nsingle
5825           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5826         enddo
5827         write (iout,*) "cosph1ph2 and sinph2ph2"
5828         do k=2,ndouble
5829           do l=1,k-1
5830             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5831                sinph1ph2(l,k),sinph1ph2(k,l)
5832           enddo
5833         enddo
5834         write(iout,*) "ethetai",ethetai
5835         endif
5836         do m=1,ntheterm2
5837           do k=1,nsingle
5838             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5839                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5840                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5841                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5842             ethetai=ethetai+sinkt(m)*aux
5843             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5844             dephii=dephii+k*sinkt(m)* &
5845                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5846                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5847             dephii1=dephii1+k*sinkt(m)* &
5848                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5849                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5850             if (lprn) &
5851             write (iout,*) "m",m," k",k," bbthet", &
5852                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5853                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5854                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5855                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5856           enddo
5857         enddo
5858         if (lprn) &
5859         write(iout,*) "ethetai",ethetai
5860         do m=1,ntheterm3
5861           do k=2,ndouble
5862             do l=1,k-1
5863               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5864                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5865                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5866                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5867               ethetai=ethetai+sinkt(m)*aux
5868               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5869               dephii=dephii+l*sinkt(m)* &
5870                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5871                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5872                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5873                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5874               dephii1=dephii1+(k-l)*sinkt(m)* &
5875                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5876                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5877                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5878                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5879               if (lprn) then
5880               write (iout,*) "m",m," k",k," l",l," ffthet",&
5881                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5882                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5883                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5884                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5885                   " ethetai",ethetai
5886               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5887                   cosph1ph2(k,l)*sinkt(m),&
5888                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5889               endif
5890             enddo
5891           enddo
5892         enddo
5893 10      continue
5894 !        lprn1=.true.
5895         if (lprn1) &
5896           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5897          i,theta(i)*rad2deg,phii*rad2deg,&
5898          phii1*rad2deg,ethetai
5899 !        lprn1=.false.
5900         etheta=etheta+ethetai
5901         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5902                                     'ebend',i,ethetai
5903         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5904         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5905         gloc(nphi+i-2,icg)=wang*dethetai
5906       enddo
5907 !-----------thete constrains
5908 !      if (tor_mode.ne.2) then
5909       ethetacnstr=0.0d0
5910 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5911       do i=ithetaconstr_start,ithetaconstr_end
5912         itheta=itheta_constr(i)
5913         thetiii=theta(itheta)
5914         difi=pinorm(thetiii-theta_constr0(i))
5915         if (difi.gt.theta_drange(i)) then
5916           difi=difi-theta_drange(i)
5917           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5918           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5919          +for_thet_constr(i)*difi**3
5920         else if (difi.lt.-drange(i)) then
5921           difi=difi+drange(i)
5922           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5923           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5924          +for_thet_constr(i)*difi**3
5925         else
5926           difi=0.0
5927         endif
5928        if (energy_dec) then
5929         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5930          i,itheta,rad2deg*thetiii, &
5931          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5932          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5933          gloc(itheta+nphi-2,icg)
5934         endif
5935       enddo
5936 !      endif
5937
5938       return
5939       end subroutine ebend
5940 #endif
5941 #ifdef CRYST_SC
5942 !-----------------------------------------------------------------------------
5943       subroutine esc(escloc)
5944 ! Calculate the local energy of a side chain and its derivatives in the
5945 ! corresponding virtual-bond valence angles THETA and the spherical angles
5946 ! ALPHA and OMEGA.
5947 !
5948       use comm_sccalc
5949 !      implicit real*8 (a-h,o-z)
5950 !      include 'DIMENSIONS'
5951 !      include 'COMMON.GEO'
5952 !      include 'COMMON.LOCAL'
5953 !      include 'COMMON.VAR'
5954 !      include 'COMMON.INTERACT'
5955 !      include 'COMMON.DERIV'
5956 !      include 'COMMON.CHAIN'
5957 !      include 'COMMON.IOUNITS'
5958 !      include 'COMMON.NAMES'
5959 !      include 'COMMON.FFIELD'
5960 !      include 'COMMON.CONTROL'
5961       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5962          ddersc0,ddummy,xtemp,temp
5963 !el      real(kind=8) :: time11,time12,time112,theti
5964       real(kind=8) :: escloc,delta
5965 !el      integer :: it,nlobit
5966 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5967 !el local variables
5968       integer :: i,k
5969       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5970        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5971       delta=0.02d0*pi
5972       escloc=0.0D0
5973 !     write (iout,'(a)') 'ESC'
5974       do i=loc_start,loc_end
5975         it=itype(i,1)
5976         if (it.eq.ntyp1) cycle
5977         if (it.eq.10) goto 1
5978         nlobit=nlob(iabs(it))
5979 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5980 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5981         theti=theta(i+1)-pipol
5982         x(1)=dtan(theti)
5983         x(2)=alph(i)
5984         x(3)=omeg(i)
5985
5986         if (x(2).gt.pi-delta) then
5987           xtemp(1)=x(1)
5988           xtemp(2)=pi-delta
5989           xtemp(3)=x(3)
5990           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5991           xtemp(2)=pi
5992           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5993           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5994               escloci,dersc(2))
5995           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5996               ddersc0(1),dersc(1))
5997           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5998               ddersc0(3),dersc(3))
5999           xtemp(2)=pi-delta
6000           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6001           xtemp(2)=pi
6002           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6003           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6004                   dersc0(2),esclocbi,dersc02)
6005           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6006                   dersc12,dersc01)
6007           call splinthet(x(2),0.5d0*delta,ss,ssd)
6008           dersc0(1)=dersc01
6009           dersc0(2)=dersc02
6010           dersc0(3)=0.0d0
6011           do k=1,3
6012             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6013           enddo
6014           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6015 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6016 !    &             esclocbi,ss,ssd
6017           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6018 !         escloci=esclocbi
6019 !         write (iout,*) escloci
6020         else if (x(2).lt.delta) then
6021           xtemp(1)=x(1)
6022           xtemp(2)=delta
6023           xtemp(3)=x(3)
6024           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6025           xtemp(2)=0.0d0
6026           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6027           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6028               escloci,dersc(2))
6029           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6030               ddersc0(1),dersc(1))
6031           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6032               ddersc0(3),dersc(3))
6033           xtemp(2)=delta
6034           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6035           xtemp(2)=0.0d0
6036           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6037           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6038                   dersc0(2),esclocbi,dersc02)
6039           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6040                   dersc12,dersc01)
6041           dersc0(1)=dersc01
6042           dersc0(2)=dersc02
6043           dersc0(3)=0.0d0
6044           call splinthet(x(2),0.5d0*delta,ss,ssd)
6045           do k=1,3
6046             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6047           enddo
6048           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6049 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6050 !    &             esclocbi,ss,ssd
6051           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6052 !         write (iout,*) escloci
6053         else
6054           call enesc(x,escloci,dersc,ddummy,.false.)
6055         endif
6056
6057         escloc=escloc+escloci
6058         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6059            'escloc',i,escloci
6060 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6061
6062         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6063          wscloc*dersc(1)
6064         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6065         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6066     1   continue
6067       enddo
6068       return
6069       end subroutine esc
6070 !-----------------------------------------------------------------------------
6071       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6072
6073       use comm_sccalc
6074 !      implicit real*8 (a-h,o-z)
6075 !      include 'DIMENSIONS'
6076 !      include 'COMMON.GEO'
6077 !      include 'COMMON.LOCAL'
6078 !      include 'COMMON.IOUNITS'
6079 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6080       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6081       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6082       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6083       real(kind=8) :: escloci
6084       logical :: mixed
6085 !el local variables
6086       integer :: j,iii,l,k !el,it,nlobit
6087       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6088 !el       time11,time12,time112
6089 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6090         escloc_i=0.0D0
6091         do j=1,3
6092           dersc(j)=0.0D0
6093           if (mixed) ddersc(j)=0.0d0
6094         enddo
6095         x3=x(3)
6096
6097 ! Because of periodicity of the dependence of the SC energy in omega we have
6098 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6099 ! To avoid underflows, first compute & store the exponents.
6100
6101         do iii=-1,1
6102
6103           x(3)=x3+iii*dwapi
6104
6105           do j=1,nlobit
6106             do k=1,3
6107               z(k)=x(k)-censc(k,j,it)
6108             enddo
6109             do k=1,3
6110               Axk=0.0D0
6111               do l=1,3
6112                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6113               enddo
6114               Ax(k,j,iii)=Axk
6115             enddo
6116             expfac=0.0D0
6117             do k=1,3
6118               expfac=expfac+Ax(k,j,iii)*z(k)
6119             enddo
6120             contr(j,iii)=expfac
6121           enddo ! j
6122
6123         enddo ! iii
6124
6125         x(3)=x3
6126 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6127 ! subsequent NaNs and INFs in energy calculation.
6128 ! Find the largest exponent
6129         emin=contr(1,-1)
6130         do iii=-1,1
6131           do j=1,nlobit
6132             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6133           enddo
6134         enddo
6135         emin=0.5D0*emin
6136 !d      print *,'it=',it,' emin=',emin
6137
6138 ! Compute the contribution to SC energy and derivatives
6139         do iii=-1,1
6140
6141           do j=1,nlobit
6142 #ifdef OSF
6143             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6144             if(adexp.ne.adexp) adexp=1.0
6145             expfac=dexp(adexp)
6146 #else
6147             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6148 #endif
6149 !d          print *,'j=',j,' expfac=',expfac
6150             escloc_i=escloc_i+expfac
6151             do k=1,3
6152               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6153             enddo
6154             if (mixed) then
6155               do k=1,3,2
6156                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6157                   +gaussc(k,2,j,it))*expfac
6158               enddo
6159             endif
6160           enddo
6161
6162         enddo ! iii
6163
6164         dersc(1)=dersc(1)/cos(theti)**2
6165         ddersc(1)=ddersc(1)/cos(theti)**2
6166         ddersc(3)=ddersc(3)
6167
6168         escloci=-(dlog(escloc_i)-emin)
6169         do j=1,3
6170           dersc(j)=dersc(j)/escloc_i
6171         enddo
6172         if (mixed) then
6173           do j=1,3,2
6174             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6175           enddo
6176         endif
6177       return
6178       end subroutine enesc
6179 !-----------------------------------------------------------------------------
6180       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6181
6182       use comm_sccalc
6183 !      implicit real*8 (a-h,o-z)
6184 !      include 'DIMENSIONS'
6185 !      include 'COMMON.GEO'
6186 !      include 'COMMON.LOCAL'
6187 !      include 'COMMON.IOUNITS'
6188 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6189       real(kind=8),dimension(3) :: x,z,dersc
6190       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6191       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6192       real(kind=8) :: escloci,dersc12,emin
6193       logical :: mixed
6194 !el local varables
6195       integer :: j,k,l !el,it,nlobit
6196       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6197
6198       escloc_i=0.0D0
6199
6200       do j=1,3
6201         dersc(j)=0.0D0
6202       enddo
6203
6204       do j=1,nlobit
6205         do k=1,2
6206           z(k)=x(k)-censc(k,j,it)
6207         enddo
6208         z(3)=dwapi
6209         do k=1,3
6210           Axk=0.0D0
6211           do l=1,3
6212             Axk=Axk+gaussc(l,k,j,it)*z(l)
6213           enddo
6214           Ax(k,j)=Axk
6215         enddo
6216         expfac=0.0D0
6217         do k=1,3
6218           expfac=expfac+Ax(k,j)*z(k)
6219         enddo
6220         contr(j)=expfac
6221       enddo ! j
6222
6223 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6224 ! subsequent NaNs and INFs in energy calculation.
6225 ! Find the largest exponent
6226       emin=contr(1)
6227       do j=1,nlobit
6228         if (emin.gt.contr(j)) emin=contr(j)
6229       enddo
6230       emin=0.5D0*emin
6231
6232 ! Compute the contribution to SC energy and derivatives
6233
6234       dersc12=0.0d0
6235       do j=1,nlobit
6236         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6237         escloc_i=escloc_i+expfac
6238         do k=1,2
6239           dersc(k)=dersc(k)+Ax(k,j)*expfac
6240         enddo
6241         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6242                   +gaussc(1,2,j,it))*expfac
6243         dersc(3)=0.0d0
6244       enddo
6245
6246       dersc(1)=dersc(1)/cos(theti)**2
6247       dersc12=dersc12/cos(theti)**2
6248       escloci=-(dlog(escloc_i)-emin)
6249       do j=1,2
6250         dersc(j)=dersc(j)/escloc_i
6251       enddo
6252       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6253       return
6254       end subroutine enesc_bound
6255 #else
6256 !-----------------------------------------------------------------------------
6257       subroutine esc(escloc)
6258 ! Calculate the local energy of a side chain and its derivatives in the
6259 ! corresponding virtual-bond valence angles THETA and the spherical angles
6260 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6261 ! added by Urszula Kozlowska. 07/11/2007
6262 !
6263       use comm_sccalc
6264 !      implicit real*8 (a-h,o-z)
6265 !      include 'DIMENSIONS'
6266 !      include 'COMMON.GEO'
6267 !      include 'COMMON.LOCAL'
6268 !      include 'COMMON.VAR'
6269 !      include 'COMMON.SCROT'
6270 !      include 'COMMON.INTERACT'
6271 !      include 'COMMON.DERIV'
6272 !      include 'COMMON.CHAIN'
6273 !      include 'COMMON.IOUNITS'
6274 !      include 'COMMON.NAMES'
6275 !      include 'COMMON.FFIELD'
6276 !      include 'COMMON.CONTROL'
6277 !      include 'COMMON.VECTORS'
6278       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6279       real(kind=8),dimension(65) :: x
6280       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6281          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6282       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6283       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6284          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6285 !el local variables
6286       integer :: i,j,k !el,it,nlobit
6287       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6288 !el      real(kind=8) :: time11,time12,time112,theti
6289 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6290       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6291                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6292                    sumene1x,sumene2x,sumene3x,sumene4x,&
6293                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6294                    cosfac2xx,sinfac2yy
6295 #ifdef DEBUG
6296       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6297                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6298                    de_dt_num
6299 #endif
6300 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6301
6302       delta=0.02d0*pi
6303       escloc=0.0D0
6304       do i=loc_start,loc_end
6305         if (itype(i,1).eq.ntyp1) cycle
6306         costtab(i+1) =dcos(theta(i+1))
6307         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6308         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6309         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6310         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6311         cosfac=dsqrt(cosfac2)
6312         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6313         sinfac=dsqrt(sinfac2)
6314         it=iabs(itype(i,1))
6315         if (it.eq.10) goto 1
6316 !
6317 !  Compute the axes of tghe local cartesian coordinates system; store in
6318 !   x_prime, y_prime and z_prime
6319 !
6320         do j=1,3
6321           x_prime(j) = 0.00
6322           y_prime(j) = 0.00
6323           z_prime(j) = 0.00
6324         enddo
6325 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6326 !     &   dc_norm(3,i+nres)
6327         do j = 1,3
6328           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6329           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6330         enddo
6331         do j = 1,3
6332           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6333         enddo
6334 !       write (2,*) "i",i
6335 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6336 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6337 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6338 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6339 !      & " xy",scalar(x_prime(1),y_prime(1)),
6340 !      & " xz",scalar(x_prime(1),z_prime(1)),
6341 !      & " yy",scalar(y_prime(1),y_prime(1)),
6342 !      & " yz",scalar(y_prime(1),z_prime(1)),
6343 !      & " zz",scalar(z_prime(1),z_prime(1))
6344 !
6345 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6346 ! to local coordinate system. Store in xx, yy, zz.
6347 !
6348         xx=0.0d0
6349         yy=0.0d0
6350         zz=0.0d0
6351         do j = 1,3
6352           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6353           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6354           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6355         enddo
6356
6357         xxtab(i)=xx
6358         yytab(i)=yy
6359         zztab(i)=zz
6360 !
6361 ! Compute the energy of the ith side cbain
6362 !
6363 !        write (2,*) "xx",xx," yy",yy," zz",zz
6364         it=iabs(itype(i,1))
6365         do j = 1,65
6366           x(j) = sc_parmin(j,it)
6367         enddo
6368 #ifdef CHECK_COORD
6369 !c diagnostics - remove later
6370         xx1 = dcos(alph(2))
6371         yy1 = dsin(alph(2))*dcos(omeg(2))
6372         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6373         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6374           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6375           xx1,yy1,zz1
6376 !,"  --- ", xx_w,yy_w,zz_w
6377 ! end diagnostics
6378 #endif
6379         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6380          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6381          + x(10)*yy*zz
6382         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6383          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6384          + x(20)*yy*zz
6385         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6386          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6387          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6388          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6389          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6390          +x(40)*xx*yy*zz
6391         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6392          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6393          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6394          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6395          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6396          +x(60)*xx*yy*zz
6397         dsc_i   = 0.743d0+x(61)
6398         dp2_i   = 1.9d0+x(62)
6399         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6400                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6401         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6402                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6403         s1=(1+x(63))/(0.1d0 + dscp1)
6404         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6405         s2=(1+x(65))/(0.1d0 + dscp2)
6406         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6407         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6408       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6409 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6410 !     &   sumene4,
6411 !     &   dscp1,dscp2,sumene
6412 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6413         escloc = escloc + sumene
6414 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6415 !     & ,zz,xx,yy
6416 !#define DEBUG
6417 #ifdef DEBUG
6418 !
6419 ! This section to check the numerical derivatives of the energy of ith side
6420 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6421 ! #define DEBUG in the code to turn it on.
6422 !
6423         write (2,*) "sumene               =",sumene
6424         aincr=1.0d-7
6425         xxsave=xx
6426         xx=xx+aincr
6427         write (2,*) xx,yy,zz
6428         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6429         de_dxx_num=(sumenep-sumene)/aincr
6430         xx=xxsave
6431         write (2,*) "xx+ sumene from enesc=",sumenep
6432         yysave=yy
6433         yy=yy+aincr
6434         write (2,*) xx,yy,zz
6435         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6436         de_dyy_num=(sumenep-sumene)/aincr
6437         yy=yysave
6438         write (2,*) "yy+ sumene from enesc=",sumenep
6439         zzsave=zz
6440         zz=zz+aincr
6441         write (2,*) xx,yy,zz
6442         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6443         de_dzz_num=(sumenep-sumene)/aincr
6444         zz=zzsave
6445         write (2,*) "zz+ sumene from enesc=",sumenep
6446         costsave=cost2tab(i+1)
6447         sintsave=sint2tab(i+1)
6448         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6449         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6450         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6451         de_dt_num=(sumenep-sumene)/aincr
6452         write (2,*) " t+ sumene from enesc=",sumenep
6453         cost2tab(i+1)=costsave
6454         sint2tab(i+1)=sintsave
6455 ! End of diagnostics section.
6456 #endif
6457 !
6458 ! Compute the gradient of esc
6459 !
6460 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6461         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6462         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6463         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6464         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6465         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6466         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6467         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6468         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6469         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6470            *(pom_s1/dscp1+pom_s16*dscp1**4)
6471         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6472            *(pom_s2/dscp2+pom_s26*dscp2**4)
6473         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6474         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6475         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6476         +x(40)*yy*zz
6477         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6478         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6479         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6480         +x(60)*yy*zz
6481         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6482               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6483               +(pom1+pom2)*pom_dx
6484 #ifdef DEBUG
6485         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6486 #endif
6487 !
6488         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6489         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6490         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6491         +x(40)*xx*zz
6492         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6493         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6494         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6495         +x(59)*zz**2 +x(60)*xx*zz
6496         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6497               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6498               +(pom1-pom2)*pom_dy
6499 #ifdef DEBUG
6500         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6501 #endif
6502 !
6503         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6504         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6505         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6506         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6507         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6508         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6509         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6510         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6511 #ifdef DEBUG
6512         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6513 #endif
6514 !
6515         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6516         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6517         +pom1*pom_dt1+pom2*pom_dt2
6518 #ifdef DEBUG
6519         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6520 #endif
6521 !
6522 !
6523        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6524        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6525        cosfac2xx=cosfac2*xx
6526        sinfac2yy=sinfac2*yy
6527        do k = 1,3
6528          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6529             vbld_inv(i+1)
6530          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6531             vbld_inv(i)
6532          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6533          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6534 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6535 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6536 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6537 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6538          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6539          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6540          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6541          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6542          dZZ_Ci1(k)=0.0d0
6543          dZZ_Ci(k)=0.0d0
6544          do j=1,3
6545            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6546            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6547            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6548            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6549          enddo
6550
6551          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6552          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6553          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6554          (z_prime(k)-zz*dC_norm(k,i+nres))
6555 !
6556          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6557          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6558        enddo
6559
6560        do k=1,3
6561          dXX_Ctab(k,i)=dXX_Ci(k)
6562          dXX_C1tab(k,i)=dXX_Ci1(k)
6563          dYY_Ctab(k,i)=dYY_Ci(k)
6564          dYY_C1tab(k,i)=dYY_Ci1(k)
6565          dZZ_Ctab(k,i)=dZZ_Ci(k)
6566          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6567          dXX_XYZtab(k,i)=dXX_XYZ(k)
6568          dYY_XYZtab(k,i)=dYY_XYZ(k)
6569          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6570        enddo
6571
6572        do k = 1,3
6573 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6574 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6575 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6576 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6577 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6578 !     &    dt_dci(k)
6579 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6580 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6581          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6582           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6583          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6584           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6585          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6586           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6587        enddo
6588 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6589 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6590
6591 ! to check gradient call subroutine check_grad
6592
6593     1 continue
6594       enddo
6595       return
6596       end subroutine esc
6597 !-----------------------------------------------------------------------------
6598       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6599 !      implicit none
6600       real(kind=8),dimension(65) :: x
6601       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6602         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6603
6604       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6605         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6606         + x(10)*yy*zz
6607       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6608         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6609         + x(20)*yy*zz
6610       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6611         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6612         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6613         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6614         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6615         +x(40)*xx*yy*zz
6616       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6617         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6618         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6619         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6620         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6621         +x(60)*xx*yy*zz
6622       dsc_i   = 0.743d0+x(61)
6623       dp2_i   = 1.9d0+x(62)
6624       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6625                 *(xx*cost2+yy*sint2))
6626       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6627                 *(xx*cost2-yy*sint2))
6628       s1=(1+x(63))/(0.1d0 + dscp1)
6629       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6630       s2=(1+x(65))/(0.1d0 + dscp2)
6631       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6632       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6633        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6634       enesc=sumene
6635       return
6636       end function enesc
6637 #endif
6638 !-----------------------------------------------------------------------------
6639       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6640 !
6641 ! This procedure calculates two-body contact function g(rij) and its derivative:
6642 !
6643 !           eps0ij                                     !       x < -1
6644 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6645 !            0                                         !       x > 1
6646 !
6647 ! where x=(rij-r0ij)/delta
6648 !
6649 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6650 !
6651 !      implicit none
6652       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6653       real(kind=8) :: x,x2,x4,delta
6654 !     delta=0.02D0*r0ij
6655 !      delta=0.2D0*r0ij
6656       x=(rij-r0ij)/delta
6657       if (x.lt.-1.0D0) then
6658         fcont=eps0ij
6659         fprimcont=0.0D0
6660       else if (x.le.1.0D0) then
6661         x2=x*x
6662         x4=x2*x2
6663         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6664         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6665       else
6666         fcont=0.0D0
6667         fprimcont=0.0D0
6668       endif
6669       return
6670       end subroutine gcont
6671 !-----------------------------------------------------------------------------
6672       subroutine splinthet(theti,delta,ss,ssder)
6673 !      implicit real*8 (a-h,o-z)
6674 !      include 'DIMENSIONS'
6675 !      include 'COMMON.VAR'
6676 !      include 'COMMON.GEO'
6677       real(kind=8) :: theti,delta,ss,ssder
6678       real(kind=8) :: thetup,thetlow
6679       thetup=pi-delta
6680       thetlow=delta
6681       if (theti.gt.pipol) then
6682         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6683       else
6684         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6685         ssder=-ssder
6686       endif
6687       return
6688       end subroutine splinthet
6689 !-----------------------------------------------------------------------------
6690       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6691 !      implicit none
6692       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6693       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6694       a1=fprim0*delta/(f1-f0)
6695       a2=3.0d0-2.0d0*a1
6696       a3=a1-2.0d0
6697       ksi=(x-x0)/delta
6698       ksi2=ksi*ksi
6699       ksi3=ksi2*ksi
6700       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6701       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6702       return
6703       end subroutine spline1
6704 !-----------------------------------------------------------------------------
6705       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6706 !      implicit none
6707       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6708       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6709       ksi=(x-x0)/delta
6710       ksi2=ksi*ksi
6711       ksi3=ksi2*ksi
6712       a1=fprim0x*delta
6713       a2=3*(f1x-f0x)-2*fprim0x*delta
6714       a3=fprim0x*delta-2*(f1x-f0x)
6715       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6716       return
6717       end subroutine spline2
6718 !-----------------------------------------------------------------------------
6719 #ifdef CRYST_TOR
6720 !-----------------------------------------------------------------------------
6721       subroutine etor(etors,edihcnstr)
6722 !      implicit real*8 (a-h,o-z)
6723 !      include 'DIMENSIONS'
6724 !      include 'COMMON.VAR'
6725 !      include 'COMMON.GEO'
6726 !      include 'COMMON.LOCAL'
6727 !      include 'COMMON.TORSION'
6728 !      include 'COMMON.INTERACT'
6729 !      include 'COMMON.DERIV'
6730 !      include 'COMMON.CHAIN'
6731 !      include 'COMMON.NAMES'
6732 !      include 'COMMON.IOUNITS'
6733 !      include 'COMMON.FFIELD'
6734 !      include 'COMMON.TORCNSTR'
6735 !      include 'COMMON.CONTROL'
6736       real(kind=8) :: etors,edihcnstr
6737       logical :: lprn
6738 !el local variables
6739       integer :: i,j,
6740       real(kind=8) :: phii,fac,etors_ii
6741
6742 ! Set lprn=.true. for debugging
6743       lprn=.false.
6744 !      lprn=.true.
6745       etors=0.0D0
6746       do i=iphi_start,iphi_end
6747       etors_ii=0.0D0
6748         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6749             .or. itype(i,1).eq.ntyp1) cycle
6750         itori=itortyp(itype(i-2,1))
6751         itori1=itortyp(itype(i-1,1))
6752         phii=phi(i)
6753         gloci=0.0D0
6754 ! Proline-Proline pair is a special case...
6755         if (itori.eq.3 .and. itori1.eq.3) then
6756           if (phii.gt.-dwapi3) then
6757             cosphi=dcos(3*phii)
6758             fac=1.0D0/(1.0D0-cosphi)
6759             etorsi=v1(1,3,3)*fac
6760             etorsi=etorsi+etorsi
6761             etors=etors+etorsi-v1(1,3,3)
6762             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6763             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6764           endif
6765           do j=1,3
6766             v1ij=v1(j+1,itori,itori1)
6767             v2ij=v2(j+1,itori,itori1)
6768             cosphi=dcos(j*phii)
6769             sinphi=dsin(j*phii)
6770             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6771             if (energy_dec) etors_ii=etors_ii+ &
6772                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6773             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6774           enddo
6775         else
6776           do j=1,nterm_old
6777             v1ij=v1(j,itori,itori1)
6778             v2ij=v2(j,itori,itori1)
6779             cosphi=dcos(j*phii)
6780             sinphi=dsin(j*phii)
6781             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6782             if (energy_dec) etors_ii=etors_ii+ &
6783                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6784             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6785           enddo
6786         endif
6787         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6788              'etor',i,etors_ii
6789         if (lprn) &
6790         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6791         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6792         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6793         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6794 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6795       enddo
6796 ! 6/20/98 - dihedral angle constraints
6797       edihcnstr=0.0d0
6798       do i=1,ndih_constr
6799         itori=idih_constr(i)
6800         phii=phi(itori)
6801         difi=phii-phi0(i)
6802         if (difi.gt.drange(i)) then
6803           difi=difi-drange(i)
6804           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6805           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6806         else if (difi.lt.-drange(i)) then
6807           difi=difi+drange(i)
6808           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6809           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6810         endif
6811 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6812 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6813       enddo
6814 !      write (iout,*) 'edihcnstr',edihcnstr
6815       return
6816       end subroutine etor
6817 !-----------------------------------------------------------------------------
6818       subroutine etor_d(etors_d)
6819       real(kind=8) :: etors_d
6820       etors_d=0.0d0
6821       return
6822       end subroutine etor_d
6823 #else
6824 !-----------------------------------------------------------------------------
6825       subroutine etor(etors,edihcnstr)
6826 !      implicit real*8 (a-h,o-z)
6827 !      include 'DIMENSIONS'
6828 !      include 'COMMON.VAR'
6829 !      include 'COMMON.GEO'
6830 !      include 'COMMON.LOCAL'
6831 !      include 'COMMON.TORSION'
6832 !      include 'COMMON.INTERACT'
6833 !      include 'COMMON.DERIV'
6834 !      include 'COMMON.CHAIN'
6835 !      include 'COMMON.NAMES'
6836 !      include 'COMMON.IOUNITS'
6837 !      include 'COMMON.FFIELD'
6838 !      include 'COMMON.TORCNSTR'
6839 !      include 'COMMON.CONTROL'
6840       real(kind=8) :: etors,edihcnstr
6841       logical :: lprn
6842 !el local variables
6843       integer :: i,j,iblock,itori,itori1
6844       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6845                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6846 ! Set lprn=.true. for debugging
6847       lprn=.false.
6848 !     lprn=.true.
6849       etors=0.0D0
6850       do i=iphi_start,iphi_end
6851         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6852              .or. itype(i-3,1).eq.ntyp1 &
6853              .or. itype(i,1).eq.ntyp1) cycle
6854         etors_ii=0.0D0
6855          if (iabs(itype(i,1)).eq.20) then
6856          iblock=2
6857          else
6858          iblock=1
6859          endif
6860         itori=itortyp(itype(i-2,1))
6861         itori1=itortyp(itype(i-1,1))
6862         phii=phi(i)
6863         gloci=0.0D0
6864 ! Regular cosine and sine terms
6865         do j=1,nterm(itori,itori1,iblock)
6866           v1ij=v1(j,itori,itori1,iblock)
6867           v2ij=v2(j,itori,itori1,iblock)
6868           cosphi=dcos(j*phii)
6869           sinphi=dsin(j*phii)
6870           etors=etors+v1ij*cosphi+v2ij*sinphi
6871           if (energy_dec) etors_ii=etors_ii+ &
6872                      v1ij*cosphi+v2ij*sinphi
6873           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6874         enddo
6875 ! Lorentz terms
6876 !                         v1
6877 !  E = SUM ----------------------------------- - v1
6878 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6879 !
6880         cosphi=dcos(0.5d0*phii)
6881         sinphi=dsin(0.5d0*phii)
6882         do j=1,nlor(itori,itori1,iblock)
6883           vl1ij=vlor1(j,itori,itori1)
6884           vl2ij=vlor2(j,itori,itori1)
6885           vl3ij=vlor3(j,itori,itori1)
6886           pom=vl2ij*cosphi+vl3ij*sinphi
6887           pom1=1.0d0/(pom*pom+1.0d0)
6888           etors=etors+vl1ij*pom1
6889           if (energy_dec) etors_ii=etors_ii+ &
6890                      vl1ij*pom1
6891           pom=-pom*pom1*pom1
6892           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6893         enddo
6894 ! Subtract the constant term
6895         etors=etors-v0(itori,itori1,iblock)
6896           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6897                'etor',i,etors_ii-v0(itori,itori1,iblock)
6898         if (lprn) &
6899         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6900         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6901         (v1(j,itori,itori1,iblock),j=1,6),&
6902         (v2(j,itori,itori1,iblock),j=1,6)
6903         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6904 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6905       enddo
6906 ! 6/20/98 - dihedral angle constraints
6907       edihcnstr=0.0d0
6908 !      do i=1,ndih_constr
6909       do i=idihconstr_start,idihconstr_end
6910         itori=idih_constr(i)
6911         phii=phi(itori)
6912         difi=pinorm(phii-phi0(i))
6913         if (difi.gt.drange(i)) then
6914           difi=difi-drange(i)
6915           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6916           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6917         else if (difi.lt.-drange(i)) then
6918           difi=difi+drange(i)
6919           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6920           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6921         else
6922           difi=0.0
6923         endif
6924 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6925 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6926 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6927       enddo
6928 !d       write (iout,*) 'edihcnstr',edihcnstr
6929       return
6930       end subroutine etor
6931 !-----------------------------------------------------------------------------
6932       subroutine etor_d(etors_d)
6933 ! 6/23/01 Compute double torsional energy
6934 !      implicit real*8 (a-h,o-z)
6935 !      include 'DIMENSIONS'
6936 !      include 'COMMON.VAR'
6937 !      include 'COMMON.GEO'
6938 !      include 'COMMON.LOCAL'
6939 !      include 'COMMON.TORSION'
6940 !      include 'COMMON.INTERACT'
6941 !      include 'COMMON.DERIV'
6942 !      include 'COMMON.CHAIN'
6943 !      include 'COMMON.NAMES'
6944 !      include 'COMMON.IOUNITS'
6945 !      include 'COMMON.FFIELD'
6946 !      include 'COMMON.TORCNSTR'
6947       real(kind=8) :: etors_d,etors_d_ii
6948       logical :: lprn
6949 !el local variables
6950       integer :: i,j,k,l,itori,itori1,itori2,iblock
6951       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6952                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6953                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6954                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6955 ! Set lprn=.true. for debugging
6956       lprn=.false.
6957 !     lprn=.true.
6958       etors_d=0.0D0
6959 !      write(iout,*) "a tu??"
6960       do i=iphid_start,iphid_end
6961         etors_d_ii=0.0D0
6962         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6963             .or. itype(i-3,1).eq.ntyp1 &
6964             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6965         itori=itortyp(itype(i-2,1))
6966         itori1=itortyp(itype(i-1,1))
6967         itori2=itortyp(itype(i,1))
6968         phii=phi(i)
6969         phii1=phi(i+1)
6970         gloci1=0.0D0
6971         gloci2=0.0D0
6972         iblock=1
6973         if (iabs(itype(i+1,1)).eq.20) iblock=2
6974
6975 ! Regular cosine and sine terms
6976         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6977           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6978           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6979           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6980           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6981           cosphi1=dcos(j*phii)
6982           sinphi1=dsin(j*phii)
6983           cosphi2=dcos(j*phii1)
6984           sinphi2=dsin(j*phii1)
6985           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6986            v2cij*cosphi2+v2sij*sinphi2
6987           if (energy_dec) etors_d_ii=etors_d_ii+ &
6988            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6989           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6990           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6991         enddo
6992         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6993           do l=1,k-1
6994             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6995             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6996             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6997             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6998             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6999             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7000             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7001             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7002             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7003               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7004             if (energy_dec) etors_d_ii=etors_d_ii+ &
7005               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7006               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7007             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7008               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7009             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7010               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7011           enddo
7012         enddo
7013         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7014                             'etor_d',i,etors_d_ii
7015         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7016         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7017       enddo
7018       return
7019       end subroutine etor_d
7020 #endif
7021 !-----------------------------------------------------------------------------
7022       subroutine eback_sc_corr(esccor)
7023 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7024 !        conformational states; temporarily implemented as differences
7025 !        between UNRES torsional potentials (dependent on three types of
7026 !        residues) and the torsional potentials dependent on all 20 types
7027 !        of residues computed from AM1  energy surfaces of terminally-blocked
7028 !        amino-acid residues.
7029 !      implicit real*8 (a-h,o-z)
7030 !      include 'DIMENSIONS'
7031 !      include 'COMMON.VAR'
7032 !      include 'COMMON.GEO'
7033 !      include 'COMMON.LOCAL'
7034 !      include 'COMMON.TORSION'
7035 !      include 'COMMON.SCCOR'
7036 !      include 'COMMON.INTERACT'
7037 !      include 'COMMON.DERIV'
7038 !      include 'COMMON.CHAIN'
7039 !      include 'COMMON.NAMES'
7040 !      include 'COMMON.IOUNITS'
7041 !      include 'COMMON.FFIELD'
7042 !      include 'COMMON.CONTROL'
7043       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7044                    cosphi,sinphi
7045       logical :: lprn
7046       integer :: i,interty,j,isccori,isccori1,intertyp
7047 ! Set lprn=.true. for debugging
7048       lprn=.false.
7049 !      lprn=.true.
7050 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7051       esccor=0.0D0
7052       do i=itau_start,itau_end
7053         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7054         esccor_ii=0.0D0
7055         isccori=isccortyp(itype(i-2,1))
7056         isccori1=isccortyp(itype(i-1,1))
7057
7058 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7059         phii=phi(i)
7060         do intertyp=1,3 !intertyp
7061          esccor_ii=0.0D0
7062 !c Added 09 May 2012 (Adasko)
7063 !c  Intertyp means interaction type of backbone mainchain correlation:
7064 !   1 = SC...Ca...Ca...Ca
7065 !   2 = Ca...Ca...Ca...SC
7066 !   3 = SC...Ca...Ca...SCi
7067         gloci=0.0D0
7068         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7069             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7070             (itype(i-1,1).eq.ntyp1))) &
7071           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7072            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7073            .or.(itype(i,1).eq.ntyp1))) &
7074           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7075             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7076             (itype(i-3,1).eq.ntyp1)))) cycle
7077         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7078         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7079        cycle
7080        do j=1,nterm_sccor(isccori,isccori1)
7081           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7082           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7083           cosphi=dcos(j*tauangle(intertyp,i))
7084           sinphi=dsin(j*tauangle(intertyp,i))
7085           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7086           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7087           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7088         enddo
7089         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7090                                 'esccor',i,intertyp,esccor_ii
7091 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7092         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7093         if (lprn) &
7094         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7095         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7096         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7097         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7098         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7099        enddo !intertyp
7100       enddo
7101
7102       return
7103       end subroutine eback_sc_corr
7104 !-----------------------------------------------------------------------------
7105       subroutine multibody(ecorr)
7106 ! This subroutine calculates multi-body contributions to energy following
7107 ! the idea of Skolnick et al. If side chains I and J make a contact and
7108 ! at the same time side chains I+1 and J+1 make a contact, an extra
7109 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7110 !      implicit real*8 (a-h,o-z)
7111 !      include 'DIMENSIONS'
7112 !      include 'COMMON.IOUNITS'
7113 !      include 'COMMON.DERIV'
7114 !      include 'COMMON.INTERACT'
7115 !      include 'COMMON.CONTACTS'
7116       real(kind=8),dimension(3) :: gx,gx1
7117       logical :: lprn
7118       real(kind=8) :: ecorr
7119       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7120 ! Set lprn=.true. for debugging
7121       lprn=.false.
7122
7123       if (lprn) then
7124         write (iout,'(a)') 'Contact function values:'
7125         do i=nnt,nct-2
7126           write (iout,'(i2,20(1x,i2,f10.5))') &
7127               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7128         enddo
7129       endif
7130       ecorr=0.0D0
7131
7132 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7133 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7134       do i=nnt,nct
7135         do j=1,3
7136           gradcorr(j,i)=0.0D0
7137           gradxorr(j,i)=0.0D0
7138         enddo
7139       enddo
7140       do i=nnt,nct-2
7141
7142         DO ISHIFT = 3,4
7143
7144         i1=i+ishift
7145         num_conti=num_cont(i)
7146         num_conti1=num_cont(i1)
7147         do jj=1,num_conti
7148           j=jcont(jj,i)
7149           do kk=1,num_conti1
7150             j1=jcont(kk,i1)
7151             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7152 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7153 !d   &                   ' ishift=',ishift
7154 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7155 ! The system gains extra energy.
7156               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7157             endif   ! j1==j+-ishift
7158           enddo     ! kk
7159         enddo       ! jj
7160
7161         ENDDO ! ISHIFT
7162
7163       enddo         ! i
7164       return
7165       end subroutine multibody
7166 !-----------------------------------------------------------------------------
7167       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7168 !      implicit real*8 (a-h,o-z)
7169 !      include 'DIMENSIONS'
7170 !      include 'COMMON.IOUNITS'
7171 !      include 'COMMON.DERIV'
7172 !      include 'COMMON.INTERACT'
7173 !      include 'COMMON.CONTACTS'
7174       real(kind=8),dimension(3) :: gx,gx1
7175       logical :: lprn
7176       integer :: i,j,k,l,jj,kk,m,ll
7177       real(kind=8) :: eij,ekl
7178       lprn=.false.
7179       eij=facont(jj,i)
7180       ekl=facont(kk,k)
7181 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7182 ! Calculate the multi-body contribution to energy.
7183 ! Calculate multi-body contributions to the gradient.
7184 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7185 !d   & k,l,(gacont(m,kk,k),m=1,3)
7186       do m=1,3
7187         gx(m) =ekl*gacont(m,jj,i)
7188         gx1(m)=eij*gacont(m,kk,k)
7189         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7190         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7191         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7192         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7193       enddo
7194       do m=i,j-1
7195         do ll=1,3
7196           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7197         enddo
7198       enddo
7199       do m=k,l-1
7200         do ll=1,3
7201           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7202         enddo
7203       enddo
7204       esccorr=-eij*ekl
7205       return
7206       end function esccorr
7207 !-----------------------------------------------------------------------------
7208       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7209 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7210 !      implicit real*8 (a-h,o-z)
7211 !      include 'DIMENSIONS'
7212 !      include 'COMMON.IOUNITS'
7213 #ifdef MPI
7214       include "mpif.h"
7215 !      integer :: maxconts !max_cont=maxconts  =nres/4
7216       integer,parameter :: max_dim=26
7217       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7218       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7219 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7220 !el      common /przechowalnia/ zapas
7221       integer :: status(MPI_STATUS_SIZE)
7222       integer,dimension((nres/4)*2) :: req !maxconts*2
7223       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7224 #endif
7225 !      include 'COMMON.SETUP'
7226 !      include 'COMMON.FFIELD'
7227 !      include 'COMMON.DERIV'
7228 !      include 'COMMON.INTERACT'
7229 !      include 'COMMON.CONTACTS'
7230 !      include 'COMMON.CONTROL'
7231 !      include 'COMMON.LOCAL'
7232       real(kind=8),dimension(3) :: gx,gx1
7233       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7234       logical :: lprn,ldone
7235 !el local variables
7236       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7237               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7238
7239 ! Set lprn=.true. for debugging
7240       lprn=.false.
7241 #ifdef MPI
7242 !      maxconts=nres/4
7243       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7244       n_corr=0
7245       n_corr1=0
7246       if (nfgtasks.le.1) goto 30
7247       if (lprn) then
7248         write (iout,'(a)') 'Contact function values before RECEIVE:'
7249         do i=nnt,nct-2
7250           write (iout,'(2i3,50(1x,i2,f5.2))') &
7251           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7252           j=1,num_cont_hb(i))
7253         enddo
7254       endif
7255       call flush(iout)
7256       do i=1,ntask_cont_from
7257         ncont_recv(i)=0
7258       enddo
7259       do i=1,ntask_cont_to
7260         ncont_sent(i)=0
7261       enddo
7262 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7263 !     & ntask_cont_to
7264 ! Make the list of contacts to send to send to other procesors
7265 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7266 !      call flush(iout)
7267       do i=iturn3_start,iturn3_end
7268 !        write (iout,*) "make contact list turn3",i," num_cont",
7269 !     &    num_cont_hb(i)
7270         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7271       enddo
7272       do i=iturn4_start,iturn4_end
7273 !        write (iout,*) "make contact list turn4",i," num_cont",
7274 !     &   num_cont_hb(i)
7275         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7276       enddo
7277       do ii=1,nat_sent
7278         i=iat_sent(ii)
7279 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7280 !     &    num_cont_hb(i)
7281         do j=1,num_cont_hb(i)
7282         do k=1,4
7283           jjc=jcont_hb(j,i)
7284           iproc=iint_sent_local(k,jjc,ii)
7285 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7286           if (iproc.gt.0) then
7287             ncont_sent(iproc)=ncont_sent(iproc)+1
7288             nn=ncont_sent(iproc)
7289             zapas(1,nn,iproc)=i
7290             zapas(2,nn,iproc)=jjc
7291             zapas(3,nn,iproc)=facont_hb(j,i)
7292             zapas(4,nn,iproc)=ees0p(j,i)
7293             zapas(5,nn,iproc)=ees0m(j,i)
7294             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7295             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7296             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7297             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7298             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7299             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7300             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7301             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7302             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7303             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7304             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7305             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7306             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7307             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7308             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7309             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7310             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7311             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7312             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7313             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7314             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7315           endif
7316         enddo
7317         enddo
7318       enddo
7319       if (lprn) then
7320       write (iout,*) &
7321         "Numbers of contacts to be sent to other processors",&
7322         (ncont_sent(i),i=1,ntask_cont_to)
7323       write (iout,*) "Contacts sent"
7324       do ii=1,ntask_cont_to
7325         nn=ncont_sent(ii)
7326         iproc=itask_cont_to(ii)
7327         write (iout,*) nn," contacts to processor",iproc,&
7328          " of CONT_TO_COMM group"
7329         do i=1,nn
7330           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7331         enddo
7332       enddo
7333       call flush(iout)
7334       endif
7335       CorrelType=477
7336       CorrelID=fg_rank+1
7337       CorrelType1=478
7338       CorrelID1=nfgtasks+fg_rank+1
7339       ireq=0
7340 ! Receive the numbers of needed contacts from other processors
7341       do ii=1,ntask_cont_from
7342         iproc=itask_cont_from(ii)
7343         ireq=ireq+1
7344         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7345           FG_COMM,req(ireq),IERR)
7346       enddo
7347 !      write (iout,*) "IRECV ended"
7348 !      call flush(iout)
7349 ! Send the number of contacts needed by other processors
7350       do ii=1,ntask_cont_to
7351         iproc=itask_cont_to(ii)
7352         ireq=ireq+1
7353         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7354           FG_COMM,req(ireq),IERR)
7355       enddo
7356 !      write (iout,*) "ISEND ended"
7357 !      write (iout,*) "number of requests (nn)",ireq
7358       call flush(iout)
7359       if (ireq.gt.0) &
7360         call MPI_Waitall(ireq,req,status_array,ierr)
7361 !      write (iout,*)
7362 !     &  "Numbers of contacts to be received from other processors",
7363 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7364 !      call flush(iout)
7365 ! Receive contacts
7366       ireq=0
7367       do ii=1,ntask_cont_from
7368         iproc=itask_cont_from(ii)
7369         nn=ncont_recv(ii)
7370 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7371 !     &   " of CONT_TO_COMM group"
7372         call flush(iout)
7373         if (nn.gt.0) then
7374           ireq=ireq+1
7375           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7376           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7377 !          write (iout,*) "ireq,req",ireq,req(ireq)
7378         endif
7379       enddo
7380 ! Send the contacts to processors that need them
7381       do ii=1,ntask_cont_to
7382         iproc=itask_cont_to(ii)
7383         nn=ncont_sent(ii)
7384 !        write (iout,*) nn," contacts to processor",iproc,
7385 !     &   " of CONT_TO_COMM group"
7386         if (nn.gt.0) then
7387           ireq=ireq+1
7388           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7389             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7390 !          write (iout,*) "ireq,req",ireq,req(ireq)
7391 !          do i=1,nn
7392 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7393 !          enddo
7394         endif
7395       enddo
7396 !      write (iout,*) "number of requests (contacts)",ireq
7397 !      write (iout,*) "req",(req(i),i=1,4)
7398 !      call flush(iout)
7399       if (ireq.gt.0) &
7400        call MPI_Waitall(ireq,req,status_array,ierr)
7401       do iii=1,ntask_cont_from
7402         iproc=itask_cont_from(iii)
7403         nn=ncont_recv(iii)
7404         if (lprn) then
7405         write (iout,*) "Received",nn," contacts from processor",iproc,&
7406          " of CONT_FROM_COMM group"
7407         call flush(iout)
7408         do i=1,nn
7409           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7410         enddo
7411         call flush(iout)
7412         endif
7413         do i=1,nn
7414           ii=zapas_recv(1,i,iii)
7415 ! Flag the received contacts to prevent double-counting
7416           jj=-zapas_recv(2,i,iii)
7417 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7418 !          call flush(iout)
7419           nnn=num_cont_hb(ii)+1
7420           num_cont_hb(ii)=nnn
7421           jcont_hb(nnn,ii)=jj
7422           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7423           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7424           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7425           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7426           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7427           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7428           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7429           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7430           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7431           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7432           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7433           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7434           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7435           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7436           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7437           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7438           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7439           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7440           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7441           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7442           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7443           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7444           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7445           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7446         enddo
7447       enddo
7448       call flush(iout)
7449       if (lprn) then
7450         write (iout,'(a)') 'Contact function values after receive:'
7451         do i=nnt,nct-2
7452           write (iout,'(2i3,50(1x,i3,f5.2))') &
7453           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7454           j=1,num_cont_hb(i))
7455         enddo
7456         call flush(iout)
7457       endif
7458    30 continue
7459 #endif
7460       if (lprn) then
7461         write (iout,'(a)') 'Contact function values:'
7462         do i=nnt,nct-2
7463           write (iout,'(2i3,50(1x,i3,f5.2))') &
7464           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7465           j=1,num_cont_hb(i))
7466         enddo
7467       endif
7468       ecorr=0.0D0
7469
7470 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7471 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7472 ! Remove the loop below after debugging !!!
7473       do i=nnt,nct
7474         do j=1,3
7475           gradcorr(j,i)=0.0D0
7476           gradxorr(j,i)=0.0D0
7477         enddo
7478       enddo
7479 ! Calculate the local-electrostatic correlation terms
7480       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7481         i1=i+1
7482         num_conti=num_cont_hb(i)
7483         num_conti1=num_cont_hb(i+1)
7484         do jj=1,num_conti
7485           j=jcont_hb(jj,i)
7486           jp=iabs(j)
7487           do kk=1,num_conti1
7488             j1=jcont_hb(kk,i1)
7489             jp1=iabs(j1)
7490 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7491 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7492             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7493                 .or. j.lt.0 .and. j1.gt.0) .and. &
7494                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7495 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7496 ! The system gains extra energy.
7497               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7498               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7499                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7500               n_corr=n_corr+1
7501             else if (j1.eq.j) then
7502 ! Contacts I-J and I-(J+1) occur simultaneously.
7503 ! The system loses extra energy.
7504 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7505             endif
7506           enddo ! kk
7507           do kk=1,num_conti
7508             j1=jcont_hb(kk,i)
7509 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7510 !    &         ' jj=',jj,' kk=',kk
7511             if (j1.eq.j+1) then
7512 ! Contacts I-J and (I+1)-J occur simultaneously.
7513 ! The system loses extra energy.
7514 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7515             endif ! j1==j+1
7516           enddo ! kk
7517         enddo ! jj
7518       enddo ! i
7519       return
7520       end subroutine multibody_hb
7521 !-----------------------------------------------------------------------------
7522       subroutine add_hb_contact(ii,jj,itask)
7523 !      implicit real*8 (a-h,o-z)
7524 !      include "DIMENSIONS"
7525 !      include "COMMON.IOUNITS"
7526 !      include "COMMON.CONTACTS"
7527 !      integer,parameter :: maxconts=nres/4
7528       integer,parameter :: max_dim=26
7529       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7530 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7531 !      common /przechowalnia/ zapas
7532       integer :: i,j,ii,jj,iproc,nn,jjc
7533       integer,dimension(4) :: itask
7534 !      write (iout,*) "itask",itask
7535       do i=1,2
7536         iproc=itask(i)
7537         if (iproc.gt.0) then
7538           do j=1,num_cont_hb(ii)
7539             jjc=jcont_hb(j,ii)
7540 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7541             if (jjc.eq.jj) then
7542               ncont_sent(iproc)=ncont_sent(iproc)+1
7543               nn=ncont_sent(iproc)
7544               zapas(1,nn,iproc)=ii
7545               zapas(2,nn,iproc)=jjc
7546               zapas(3,nn,iproc)=facont_hb(j,ii)
7547               zapas(4,nn,iproc)=ees0p(j,ii)
7548               zapas(5,nn,iproc)=ees0m(j,ii)
7549               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7550               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7551               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7552               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7553               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7554               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7555               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7556               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7557               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7558               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7559               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7560               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7561               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7562               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7563               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7564               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7565               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7566               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7567               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7568               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7569               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7570               exit
7571             endif
7572           enddo
7573         endif
7574       enddo
7575       return
7576       end subroutine add_hb_contact
7577 !-----------------------------------------------------------------------------
7578       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7579 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7580 !      implicit real*8 (a-h,o-z)
7581 !      include 'DIMENSIONS'
7582 !      include 'COMMON.IOUNITS'
7583       integer,parameter :: max_dim=70
7584 #ifdef MPI
7585       include "mpif.h"
7586 !      integer :: maxconts !max_cont=maxconts=nres/4
7587       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7588       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7589 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7590 !      common /przechowalnia/ zapas
7591       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7592         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7593         ierr,iii,nnn
7594 #endif
7595 !      include 'COMMON.SETUP'
7596 !      include 'COMMON.FFIELD'
7597 !      include 'COMMON.DERIV'
7598 !      include 'COMMON.LOCAL'
7599 !      include 'COMMON.INTERACT'
7600 !      include 'COMMON.CONTACTS'
7601 !      include 'COMMON.CHAIN'
7602 !      include 'COMMON.CONTROL'
7603       real(kind=8),dimension(3) :: gx,gx1
7604       integer,dimension(nres) :: num_cont_hb_old
7605       logical :: lprn,ldone
7606 !EL      double precision eello4,eello5,eelo6,eello_turn6
7607 !EL      external eello4,eello5,eello6,eello_turn6
7608 !el local variables
7609       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7610               j1,jp1,i1,num_conti1
7611       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7612       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7613
7614 ! Set lprn=.true. for debugging
7615       lprn=.false.
7616       eturn6=0.0d0
7617 #ifdef MPI
7618 !      maxconts=nres/4
7619       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7620       do i=1,nres
7621         num_cont_hb_old(i)=num_cont_hb(i)
7622       enddo
7623       n_corr=0
7624       n_corr1=0
7625       if (nfgtasks.le.1) goto 30
7626       if (lprn) then
7627         write (iout,'(a)') 'Contact function values before RECEIVE:'
7628         do i=nnt,nct-2
7629           write (iout,'(2i3,50(1x,i2,f5.2))') &
7630           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7631           j=1,num_cont_hb(i))
7632         enddo
7633       endif
7634       call flush(iout)
7635       do i=1,ntask_cont_from
7636         ncont_recv(i)=0
7637       enddo
7638       do i=1,ntask_cont_to
7639         ncont_sent(i)=0
7640       enddo
7641 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7642 !     & ntask_cont_to
7643 ! Make the list of contacts to send to send to other procesors
7644       do i=iturn3_start,iturn3_end
7645 !        write (iout,*) "make contact list turn3",i," num_cont",
7646 !     &    num_cont_hb(i)
7647         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7648       enddo
7649       do i=iturn4_start,iturn4_end
7650 !        write (iout,*) "make contact list turn4",i," num_cont",
7651 !     &   num_cont_hb(i)
7652         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7653       enddo
7654       do ii=1,nat_sent
7655         i=iat_sent(ii)
7656 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7657 !     &    num_cont_hb(i)
7658         do j=1,num_cont_hb(i)
7659         do k=1,4
7660           jjc=jcont_hb(j,i)
7661           iproc=iint_sent_local(k,jjc,ii)
7662 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7663           if (iproc.ne.0) then
7664             ncont_sent(iproc)=ncont_sent(iproc)+1
7665             nn=ncont_sent(iproc)
7666             zapas(1,nn,iproc)=i
7667             zapas(2,nn,iproc)=jjc
7668             zapas(3,nn,iproc)=d_cont(j,i)
7669             ind=3
7670             do kk=1,3
7671               ind=ind+1
7672               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7673             enddo
7674             do kk=1,2
7675               do ll=1,2
7676                 ind=ind+1
7677                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7678               enddo
7679             enddo
7680             do jj=1,5
7681               do kk=1,3
7682                 do ll=1,2
7683                   do mm=1,2
7684                     ind=ind+1
7685                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7686                   enddo
7687                 enddo
7688               enddo
7689             enddo
7690           endif
7691         enddo
7692         enddo
7693       enddo
7694       if (lprn) then
7695       write (iout,*) &
7696         "Numbers of contacts to be sent to other processors",&
7697         (ncont_sent(i),i=1,ntask_cont_to)
7698       write (iout,*) "Contacts sent"
7699       do ii=1,ntask_cont_to
7700         nn=ncont_sent(ii)
7701         iproc=itask_cont_to(ii)
7702         write (iout,*) nn," contacts to processor",iproc,&
7703          " of CONT_TO_COMM group"
7704         do i=1,nn
7705           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7706         enddo
7707       enddo
7708       call flush(iout)
7709       endif
7710       CorrelType=477
7711       CorrelID=fg_rank+1
7712       CorrelType1=478
7713       CorrelID1=nfgtasks+fg_rank+1
7714       ireq=0
7715 ! Receive the numbers of needed contacts from other processors
7716       do ii=1,ntask_cont_from
7717         iproc=itask_cont_from(ii)
7718         ireq=ireq+1
7719         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7720           FG_COMM,req(ireq),IERR)
7721       enddo
7722 !      write (iout,*) "IRECV ended"
7723 !      call flush(iout)
7724 ! Send the number of contacts needed by other processors
7725       do ii=1,ntask_cont_to
7726         iproc=itask_cont_to(ii)
7727         ireq=ireq+1
7728         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7729           FG_COMM,req(ireq),IERR)
7730       enddo
7731 !      write (iout,*) "ISEND ended"
7732 !      write (iout,*) "number of requests (nn)",ireq
7733       call flush(iout)
7734       if (ireq.gt.0) &
7735         call MPI_Waitall(ireq,req,status_array,ierr)
7736 !      write (iout,*)
7737 !     &  "Numbers of contacts to be received from other processors",
7738 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7739 !      call flush(iout)
7740 ! Receive contacts
7741       ireq=0
7742       do ii=1,ntask_cont_from
7743         iproc=itask_cont_from(ii)
7744         nn=ncont_recv(ii)
7745 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7746 !     &   " of CONT_TO_COMM group"
7747         call flush(iout)
7748         if (nn.gt.0) then
7749           ireq=ireq+1
7750           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7751           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7752 !          write (iout,*) "ireq,req",ireq,req(ireq)
7753         endif
7754       enddo
7755 ! Send the contacts to processors that need them
7756       do ii=1,ntask_cont_to
7757         iproc=itask_cont_to(ii)
7758         nn=ncont_sent(ii)
7759 !        write (iout,*) nn," contacts to processor",iproc,
7760 !     &   " of CONT_TO_COMM group"
7761         if (nn.gt.0) then
7762           ireq=ireq+1
7763           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7764             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7765 !          write (iout,*) "ireq,req",ireq,req(ireq)
7766 !          do i=1,nn
7767 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7768 !          enddo
7769         endif
7770       enddo
7771 !      write (iout,*) "number of requests (contacts)",ireq
7772 !      write (iout,*) "req",(req(i),i=1,4)
7773 !      call flush(iout)
7774       if (ireq.gt.0) &
7775        call MPI_Waitall(ireq,req,status_array,ierr)
7776       do iii=1,ntask_cont_from
7777         iproc=itask_cont_from(iii)
7778         nn=ncont_recv(iii)
7779         if (lprn) then
7780         write (iout,*) "Received",nn," contacts from processor",iproc,&
7781          " of CONT_FROM_COMM group"
7782         call flush(iout)
7783         do i=1,nn
7784           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7785         enddo
7786         call flush(iout)
7787         endif
7788         do i=1,nn
7789           ii=zapas_recv(1,i,iii)
7790 ! Flag the received contacts to prevent double-counting
7791           jj=-zapas_recv(2,i,iii)
7792 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7793 !          call flush(iout)
7794           nnn=num_cont_hb(ii)+1
7795           num_cont_hb(ii)=nnn
7796           jcont_hb(nnn,ii)=jj
7797           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7798           ind=3
7799           do kk=1,3
7800             ind=ind+1
7801             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7802           enddo
7803           do kk=1,2
7804             do ll=1,2
7805               ind=ind+1
7806               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7807             enddo
7808           enddo
7809           do jj=1,5
7810             do kk=1,3
7811               do ll=1,2
7812                 do mm=1,2
7813                   ind=ind+1
7814                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7815                 enddo
7816               enddo
7817             enddo
7818           enddo
7819         enddo
7820       enddo
7821       call flush(iout)
7822       if (lprn) then
7823         write (iout,'(a)') 'Contact function values after receive:'
7824         do i=nnt,nct-2
7825           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7826           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7827           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7828         enddo
7829         call flush(iout)
7830       endif
7831    30 continue
7832 #endif
7833       if (lprn) then
7834         write (iout,'(a)') 'Contact function values:'
7835         do i=nnt,nct-2
7836           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7837           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7838           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7839         enddo
7840       endif
7841       ecorr=0.0D0
7842       ecorr5=0.0d0
7843       ecorr6=0.0d0
7844
7845 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7846 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7847 ! Remove the loop below after debugging !!!
7848       do i=nnt,nct
7849         do j=1,3
7850           gradcorr(j,i)=0.0D0
7851           gradxorr(j,i)=0.0D0
7852         enddo
7853       enddo
7854 ! Calculate the dipole-dipole interaction energies
7855       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7856       do i=iatel_s,iatel_e+1
7857         num_conti=num_cont_hb(i)
7858         do jj=1,num_conti
7859           j=jcont_hb(jj,i)
7860 #ifdef MOMENT
7861           call dipole(i,j,jj)
7862 #endif
7863         enddo
7864       enddo
7865       endif
7866 ! Calculate the local-electrostatic correlation terms
7867 !                write (iout,*) "gradcorr5 in eello5 before loop"
7868 !                do iii=1,nres
7869 !                  write (iout,'(i5,3f10.5)')
7870 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7871 !                enddo
7872       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7873 !        write (iout,*) "corr loop i",i
7874         i1=i+1
7875         num_conti=num_cont_hb(i)
7876         num_conti1=num_cont_hb(i+1)
7877         do jj=1,num_conti
7878           j=jcont_hb(jj,i)
7879           jp=iabs(j)
7880           do kk=1,num_conti1
7881             j1=jcont_hb(kk,i1)
7882             jp1=iabs(j1)
7883 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7884 !     &         ' jj=',jj,' kk=',kk
7885 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7886             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7887                 .or. j.lt.0 .and. j1.gt.0) .and. &
7888                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7889 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7890 ! The system gains extra energy.
7891               n_corr=n_corr+1
7892               sqd1=dsqrt(d_cont(jj,i))
7893               sqd2=dsqrt(d_cont(kk,i1))
7894               sred_geom = sqd1*sqd2
7895               IF (sred_geom.lt.cutoff_corr) THEN
7896                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7897                   ekont,fprimcont)
7898 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7899 !d     &         ' jj=',jj,' kk=',kk
7900                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7901                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7902                 do l=1,3
7903                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7904                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7905                 enddo
7906                 n_corr1=n_corr1+1
7907 !d               write (iout,*) 'sred_geom=',sred_geom,
7908 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7909 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7910 !d               write (iout,*) "g_contij",g_contij
7911 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7912 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7913                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7914                 if (wcorr4.gt.0.0d0) &
7915                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7916                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7917                        write (iout,'(a6,4i5,0pf7.3)') &
7918                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7919 !                write (iout,*) "gradcorr5 before eello5"
7920 !                do iii=1,nres
7921 !                  write (iout,'(i5,3f10.5)')
7922 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7923 !                enddo
7924                 if (wcorr5.gt.0.0d0) &
7925                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7926 !                write (iout,*) "gradcorr5 after eello5"
7927 !                do iii=1,nres
7928 !                  write (iout,'(i5,3f10.5)')
7929 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7930 !                enddo
7931                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7932                        write (iout,'(a6,4i5,0pf7.3)') &
7933                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7934 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7935 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7936                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7937                      .or. wturn6.eq.0.0d0))then
7938 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7939                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7940                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7941                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7942 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7943 !d     &            'ecorr6=',ecorr6
7944 !d                write (iout,'(4e15.5)') sred_geom,
7945 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7946 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7947 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7948                 else if (wturn6.gt.0.0d0 &
7949                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7950 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7951                   eturn6=eturn6+eello_turn6(i,jj,kk)
7952                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7953                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7954 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7955                 endif
7956               ENDIF
7957 1111          continue
7958             endif
7959           enddo ! kk
7960         enddo ! jj
7961       enddo ! i
7962       do i=1,nres
7963         num_cont_hb(i)=num_cont_hb_old(i)
7964       enddo
7965 !                write (iout,*) "gradcorr5 in eello5"
7966 !                do iii=1,nres
7967 !                  write (iout,'(i5,3f10.5)')
7968 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7969 !                enddo
7970       return
7971       end subroutine multibody_eello
7972 !-----------------------------------------------------------------------------
7973       subroutine add_hb_contact_eello(ii,jj,itask)
7974 !      implicit real*8 (a-h,o-z)
7975 !      include "DIMENSIONS"
7976 !      include "COMMON.IOUNITS"
7977 !      include "COMMON.CONTACTS"
7978 !      integer,parameter :: maxconts=nres/4
7979       integer,parameter :: max_dim=70
7980       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7981 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7982 !      common /przechowalnia/ zapas
7983
7984       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7985       integer,dimension(4) ::itask
7986 !      write (iout,*) "itask",itask
7987       do i=1,2
7988         iproc=itask(i)
7989         if (iproc.gt.0) then
7990           do j=1,num_cont_hb(ii)
7991             jjc=jcont_hb(j,ii)
7992 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7993             if (jjc.eq.jj) then
7994               ncont_sent(iproc)=ncont_sent(iproc)+1
7995               nn=ncont_sent(iproc)
7996               zapas(1,nn,iproc)=ii
7997               zapas(2,nn,iproc)=jjc
7998               zapas(3,nn,iproc)=d_cont(j,ii)
7999               ind=3
8000               do kk=1,3
8001                 ind=ind+1
8002                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8003               enddo
8004               do kk=1,2
8005                 do ll=1,2
8006                   ind=ind+1
8007                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8008                 enddo
8009               enddo
8010               do jj=1,5
8011                 do kk=1,3
8012                   do ll=1,2
8013                     do mm=1,2
8014                       ind=ind+1
8015                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8016                     enddo
8017                   enddo
8018                 enddo
8019               enddo
8020               exit
8021             endif
8022           enddo
8023         endif
8024       enddo
8025       return
8026       end subroutine add_hb_contact_eello
8027 !-----------------------------------------------------------------------------
8028       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8029 !      implicit real*8 (a-h,o-z)
8030 !      include 'DIMENSIONS'
8031 !      include 'COMMON.IOUNITS'
8032 !      include 'COMMON.DERIV'
8033 !      include 'COMMON.INTERACT'
8034 !      include 'COMMON.CONTACTS'
8035       real(kind=8),dimension(3) :: gx,gx1
8036       logical :: lprn
8037 !el local variables
8038       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8039       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8040                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8041                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8042                    rlocshield
8043
8044       lprn=.false.
8045       eij=facont_hb(jj,i)
8046       ekl=facont_hb(kk,k)
8047       ees0pij=ees0p(jj,i)
8048       ees0pkl=ees0p(kk,k)
8049       ees0mij=ees0m(jj,i)
8050       ees0mkl=ees0m(kk,k)
8051       ekont=eij*ekl
8052       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8053 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8054 ! Following 4 lines for diagnostics.
8055 !d    ees0pkl=0.0D0
8056 !d    ees0pij=1.0D0
8057 !d    ees0mkl=0.0D0
8058 !d    ees0mij=1.0D0
8059 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8060 !     & 'Contacts ',i,j,
8061 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8062 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8063 !     & 'gradcorr_long'
8064 ! Calculate the multi-body contribution to energy.
8065 !      ecorr=ecorr+ekont*ees
8066 ! Calculate multi-body contributions to the gradient.
8067       coeffpees0pij=coeffp*ees0pij
8068       coeffmees0mij=coeffm*ees0mij
8069       coeffpees0pkl=coeffp*ees0pkl
8070       coeffmees0mkl=coeffm*ees0mkl
8071       do ll=1,3
8072 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8073         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8074         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8075         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8076         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8077         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8078         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8079 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8080         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8081         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8082         coeffmees0mij*gacontm_hb1(ll,kk,k))
8083         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8084         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8085         coeffmees0mij*gacontm_hb2(ll,kk,k))
8086         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8087            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8088            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8089         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8090         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8091         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8092            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8093            coeffmees0mij*gacontm_hb3(ll,kk,k))
8094         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8095         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8096 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8097       enddo
8098 !      write (iout,*)
8099 !grad      do m=i+1,j-1
8100 !grad        do ll=1,3
8101 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8102 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8103 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8104 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8105 !grad        enddo
8106 !grad      enddo
8107 !grad      do m=k+1,l-1
8108 !grad        do ll=1,3
8109 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8110 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8111 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8112 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8113 !grad        enddo
8114 !grad      enddo
8115 !      write (iout,*) "ehbcorr",ekont*ees
8116       ehbcorr=ekont*ees
8117       if (shield_mode.gt.0) then
8118        j=ees0plist(jj,i)
8119        l=ees0plist(kk,k)
8120 !C        print *,i,j,fac_shield(i),fac_shield(j),
8121 !C     &fac_shield(k),fac_shield(l)
8122         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8123            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8124           do ilist=1,ishield_list(i)
8125            iresshield=shield_list(ilist,i)
8126            do m=1,3
8127            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8128            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8129                    rlocshield  &
8130             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8131             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8132             +rlocshield
8133            enddo
8134           enddo
8135           do ilist=1,ishield_list(j)
8136            iresshield=shield_list(ilist,j)
8137            do m=1,3
8138            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8139            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8140                    rlocshield &
8141             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8142            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8143             +rlocshield
8144            enddo
8145           enddo
8146
8147           do ilist=1,ishield_list(k)
8148            iresshield=shield_list(ilist,k)
8149            do m=1,3
8150            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8151            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8152                    rlocshield &
8153             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8154            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8155             +rlocshield
8156            enddo
8157           enddo
8158           do ilist=1,ishield_list(l)
8159            iresshield=shield_list(ilist,l)
8160            do m=1,3
8161            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8162            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8163                    rlocshield &
8164             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8165            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8166             +rlocshield
8167            enddo
8168           enddo
8169           do m=1,3
8170             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8171                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8172             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8173                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8174             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8175                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8176             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8177                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8178
8179             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8180                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8181             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8182                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8183             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8184                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8185             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8186                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8187
8188            enddo
8189       endif
8190       endif
8191       return
8192       end function ehbcorr
8193 #ifdef MOMENT
8194 !-----------------------------------------------------------------------------
8195       subroutine dipole(i,j,jj)
8196 !      implicit real*8 (a-h,o-z)
8197 !      include 'DIMENSIONS'
8198 !      include 'COMMON.IOUNITS'
8199 !      include 'COMMON.CHAIN'
8200 !      include 'COMMON.FFIELD'
8201 !      include 'COMMON.DERIV'
8202 !      include 'COMMON.INTERACT'
8203 !      include 'COMMON.CONTACTS'
8204 !      include 'COMMON.TORSION'
8205 !      include 'COMMON.VAR'
8206 !      include 'COMMON.GEO'
8207       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8208       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8209       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8210
8211       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8212       allocate(dipderx(3,5,4,maxconts,nres))
8213 !
8214
8215       iti1 = itortyp(itype(i+1,1))
8216       if (j.lt.nres-1) then
8217         itj1 = itortyp(itype(j+1,1))
8218       else
8219         itj1=ntortyp+1
8220       endif
8221       do iii=1,2
8222         dipi(iii,1)=Ub2(iii,i)
8223         dipderi(iii)=Ub2der(iii,i)
8224         dipi(iii,2)=b1(iii,iti1)
8225         dipj(iii,1)=Ub2(iii,j)
8226         dipderj(iii)=Ub2der(iii,j)
8227         dipj(iii,2)=b1(iii,itj1)
8228       enddo
8229       kkk=0
8230       do iii=1,2
8231         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8232         do jjj=1,2
8233           kkk=kkk+1
8234           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8235         enddo
8236       enddo
8237       do kkk=1,5
8238         do lll=1,3
8239           mmm=0
8240           do iii=1,2
8241             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8242               auxvec(1))
8243             do jjj=1,2
8244               mmm=mmm+1
8245               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8246             enddo
8247           enddo
8248         enddo
8249       enddo
8250       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8251       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8252       do iii=1,2
8253         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8254       enddo
8255       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8256       do iii=1,2
8257         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8258       enddo
8259       return
8260       end subroutine dipole
8261 #endif
8262 !-----------------------------------------------------------------------------
8263       subroutine calc_eello(i,j,k,l,jj,kk)
8264 !
8265 ! This subroutine computes matrices and vectors needed to calculate
8266 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8267 !
8268       use comm_kut
8269 !      implicit real*8 (a-h,o-z)
8270 !      include 'DIMENSIONS'
8271 !      include 'COMMON.IOUNITS'
8272 !      include 'COMMON.CHAIN'
8273 !      include 'COMMON.DERIV'
8274 !      include 'COMMON.INTERACT'
8275 !      include 'COMMON.CONTACTS'
8276 !      include 'COMMON.TORSION'
8277 !      include 'COMMON.VAR'
8278 !      include 'COMMON.GEO'
8279 !      include 'COMMON.FFIELD'
8280       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8281       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8282       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8283               itj1
8284 !el      logical :: lprn
8285 !el      common /kutas/ lprn
8286 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8287 !d     & ' jj=',jj,' kk=',kk
8288 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8289 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8290 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8291       do iii=1,2
8292         do jjj=1,2
8293           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8294           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8295         enddo
8296       enddo
8297       call transpose2(aa1(1,1),aa1t(1,1))
8298       call transpose2(aa2(1,1),aa2t(1,1))
8299       do kkk=1,5
8300         do lll=1,3
8301           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8302             aa1tder(1,1,lll,kkk))
8303           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8304             aa2tder(1,1,lll,kkk))
8305         enddo
8306       enddo
8307       if (l.eq.j+1) then
8308 ! parallel orientation of the two CA-CA-CA frames.
8309         if (i.gt.1) then
8310           iti=itortyp(itype(i,1))
8311         else
8312           iti=ntortyp+1
8313         endif
8314         itk1=itortyp(itype(k+1,1))
8315         itj=itortyp(itype(j,1))
8316         if (l.lt.nres-1) then
8317           itl1=itortyp(itype(l+1,1))
8318         else
8319           itl1=ntortyp+1
8320         endif
8321 ! A1 kernel(j+1) A2T
8322 !d        do iii=1,2
8323 !d          write (iout,'(3f10.5,5x,3f10.5)')
8324 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8325 !d        enddo
8326         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8327          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8328          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8329 ! Following matrices are needed only for 6-th order cumulants
8330         IF (wcorr6.gt.0.0d0) THEN
8331         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8332          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8333          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8334         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8335          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8336          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8337          ADtEAderx(1,1,1,1,1,1))
8338         lprn=.false.
8339         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8340          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8341          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8342          ADtEA1derx(1,1,1,1,1,1))
8343         ENDIF
8344 ! End 6-th order cumulants
8345 !d        lprn=.false.
8346 !d        if (lprn) then
8347 !d        write (2,*) 'In calc_eello6'
8348 !d        do iii=1,2
8349 !d          write (2,*) 'iii=',iii
8350 !d          do kkk=1,5
8351 !d            write (2,*) 'kkk=',kkk
8352 !d            do jjj=1,2
8353 !d              write (2,'(3(2f10.5),5x)')
8354 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8355 !d            enddo
8356 !d          enddo
8357 !d        enddo
8358 !d        endif
8359         call transpose2(EUgder(1,1,k),auxmat(1,1))
8360         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8361         call transpose2(EUg(1,1,k),auxmat(1,1))
8362         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8363         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8364         do iii=1,2
8365           do kkk=1,5
8366             do lll=1,3
8367               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8368                 EAEAderx(1,1,lll,kkk,iii,1))
8369             enddo
8370           enddo
8371         enddo
8372 ! A1T kernel(i+1) A2
8373         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8374          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8375          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8376 ! Following matrices are needed only for 6-th order cumulants
8377         IF (wcorr6.gt.0.0d0) THEN
8378         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8379          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8380          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8381         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8382          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8383          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8384          ADtEAderx(1,1,1,1,1,2))
8385         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8386          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8387          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8388          ADtEA1derx(1,1,1,1,1,2))
8389         ENDIF
8390 ! End 6-th order cumulants
8391         call transpose2(EUgder(1,1,l),auxmat(1,1))
8392         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8393         call transpose2(EUg(1,1,l),auxmat(1,1))
8394         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8395         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8396         do iii=1,2
8397           do kkk=1,5
8398             do lll=1,3
8399               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8400                 EAEAderx(1,1,lll,kkk,iii,2))
8401             enddo
8402           enddo
8403         enddo
8404 ! AEAb1 and AEAb2
8405 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8406 ! They are needed only when the fifth- or the sixth-order cumulants are
8407 ! indluded.
8408         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8409         call transpose2(AEA(1,1,1),auxmat(1,1))
8410         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8411         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8412         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8413         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8414         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8415         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8416         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8417         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8418         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8419         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8420         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8421         call transpose2(AEA(1,1,2),auxmat(1,1))
8422         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8423         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8424         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8425         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8426         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8427         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8428         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8429         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8430         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8431         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8432         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8433 ! Calculate the Cartesian derivatives of the vectors.
8434         do iii=1,2
8435           do kkk=1,5
8436             do lll=1,3
8437               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8438               call matvec2(auxmat(1,1),b1(1,iti),&
8439                 AEAb1derx(1,lll,kkk,iii,1,1))
8440               call matvec2(auxmat(1,1),Ub2(1,i),&
8441                 AEAb2derx(1,lll,kkk,iii,1,1))
8442               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8443                 AEAb1derx(1,lll,kkk,iii,2,1))
8444               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8445                 AEAb2derx(1,lll,kkk,iii,2,1))
8446               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8447               call matvec2(auxmat(1,1),b1(1,itj),&
8448                 AEAb1derx(1,lll,kkk,iii,1,2))
8449               call matvec2(auxmat(1,1),Ub2(1,j),&
8450                 AEAb2derx(1,lll,kkk,iii,1,2))
8451               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8452                 AEAb1derx(1,lll,kkk,iii,2,2))
8453               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8454                 AEAb2derx(1,lll,kkk,iii,2,2))
8455             enddo
8456           enddo
8457         enddo
8458         ENDIF
8459 ! End vectors
8460       else
8461 ! Antiparallel orientation of the two CA-CA-CA frames.
8462         if (i.gt.1) then
8463           iti=itortyp(itype(i,1))
8464         else
8465           iti=ntortyp+1
8466         endif
8467         itk1=itortyp(itype(k+1,1))
8468         itl=itortyp(itype(l,1))
8469         itj=itortyp(itype(j,1))
8470         if (j.lt.nres-1) then
8471           itj1=itortyp(itype(j+1,1))
8472         else
8473           itj1=ntortyp+1
8474         endif
8475 ! A2 kernel(j-1)T A1T
8476         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8477          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8478          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8479 ! Following matrices are needed only for 6-th order cumulants
8480         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8481            j.eq.i+4 .and. l.eq.i+3)) THEN
8482         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8483          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8484          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8485         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8486          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8487          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8488          ADtEAderx(1,1,1,1,1,1))
8489         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8490          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8491          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8492          ADtEA1derx(1,1,1,1,1,1))
8493         ENDIF
8494 ! End 6-th order cumulants
8495         call transpose2(EUgder(1,1,k),auxmat(1,1))
8496         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8497         call transpose2(EUg(1,1,k),auxmat(1,1))
8498         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8499         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8500         do iii=1,2
8501           do kkk=1,5
8502             do lll=1,3
8503               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8504                 EAEAderx(1,1,lll,kkk,iii,1))
8505             enddo
8506           enddo
8507         enddo
8508 ! A2T kernel(i+1)T A1
8509         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8510          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8511          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8512 ! Following matrices are needed only for 6-th order cumulants
8513         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8514            j.eq.i+4 .and. l.eq.i+3)) THEN
8515         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8516          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8517          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8518         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8519          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8520          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8521          ADtEAderx(1,1,1,1,1,2))
8522         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8523          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8524          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8525          ADtEA1derx(1,1,1,1,1,2))
8526         ENDIF
8527 ! End 6-th order cumulants
8528         call transpose2(EUgder(1,1,j),auxmat(1,1))
8529         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8530         call transpose2(EUg(1,1,j),auxmat(1,1))
8531         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8532         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8533         do iii=1,2
8534           do kkk=1,5
8535             do lll=1,3
8536               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8537                 EAEAderx(1,1,lll,kkk,iii,2))
8538             enddo
8539           enddo
8540         enddo
8541 ! AEAb1 and AEAb2
8542 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8543 ! They are needed only when the fifth- or the sixth-order cumulants are
8544 ! indluded.
8545         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8546           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8547         call transpose2(AEA(1,1,1),auxmat(1,1))
8548         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8549         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8550         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8551         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8552         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8553         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8554         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8555         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8556         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8557         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8558         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8559         call transpose2(AEA(1,1,2),auxmat(1,1))
8560         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8561         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8562         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8563         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8564         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8565         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8566         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8567         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8568         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8569         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8570         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8571 ! Calculate the Cartesian derivatives of the vectors.
8572         do iii=1,2
8573           do kkk=1,5
8574             do lll=1,3
8575               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8576               call matvec2(auxmat(1,1),b1(1,iti),&
8577                 AEAb1derx(1,lll,kkk,iii,1,1))
8578               call matvec2(auxmat(1,1),Ub2(1,i),&
8579                 AEAb2derx(1,lll,kkk,iii,1,1))
8580               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8581                 AEAb1derx(1,lll,kkk,iii,2,1))
8582               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8583                 AEAb2derx(1,lll,kkk,iii,2,1))
8584               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8585               call matvec2(auxmat(1,1),b1(1,itl),&
8586                 AEAb1derx(1,lll,kkk,iii,1,2))
8587               call matvec2(auxmat(1,1),Ub2(1,l),&
8588                 AEAb2derx(1,lll,kkk,iii,1,2))
8589               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8590                 AEAb1derx(1,lll,kkk,iii,2,2))
8591               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8592                 AEAb2derx(1,lll,kkk,iii,2,2))
8593             enddo
8594           enddo
8595         enddo
8596         ENDIF
8597 ! End vectors
8598       endif
8599       return
8600       end subroutine calc_eello
8601 !-----------------------------------------------------------------------------
8602       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8603       use comm_kut
8604       implicit none
8605       integer :: nderg
8606       logical :: transp
8607       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8608       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8609       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8610       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8611       integer :: iii,kkk,lll
8612       integer :: jjj,mmm
8613 !el      logical :: lprn
8614 !el      common /kutas/ lprn
8615       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8616       do iii=1,nderg
8617         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8618           AKAderg(1,1,iii))
8619       enddo
8620 !d      if (lprn) write (2,*) 'In kernel'
8621       do kkk=1,5
8622 !d        if (lprn) write (2,*) 'kkk=',kkk
8623         do lll=1,3
8624           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8625             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8626 !d          if (lprn) then
8627 !d            write (2,*) 'lll=',lll
8628 !d            write (2,*) 'iii=1'
8629 !d            do jjj=1,2
8630 !d              write (2,'(3(2f10.5),5x)')
8631 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8632 !d            enddo
8633 !d          endif
8634           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8635             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8636 !d          if (lprn) then
8637 !d            write (2,*) 'lll=',lll
8638 !d            write (2,*) 'iii=2'
8639 !d            do jjj=1,2
8640 !d              write (2,'(3(2f10.5),5x)')
8641 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8642 !d            enddo
8643 !d          endif
8644         enddo
8645       enddo
8646       return
8647       end subroutine kernel
8648 !-----------------------------------------------------------------------------
8649       real(kind=8) function eello4(i,j,k,l,jj,kk)
8650 !      implicit real*8 (a-h,o-z)
8651 !      include 'DIMENSIONS'
8652 !      include 'COMMON.IOUNITS'
8653 !      include 'COMMON.CHAIN'
8654 !      include 'COMMON.DERIV'
8655 !      include 'COMMON.INTERACT'
8656 !      include 'COMMON.CONTACTS'
8657 !      include 'COMMON.TORSION'
8658 !      include 'COMMON.VAR'
8659 !      include 'COMMON.GEO'
8660       real(kind=8),dimension(2,2) :: pizda
8661       real(kind=8),dimension(3) :: ggg1,ggg2
8662       real(kind=8) ::  eel4,glongij,glongkl
8663       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8664 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8665 !d        eello4=0.0d0
8666 !d        return
8667 !d      endif
8668 !d      print *,'eello4:',i,j,k,l,jj,kk
8669 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8670 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8671 !old      eij=facont_hb(jj,i)
8672 !old      ekl=facont_hb(kk,k)
8673 !old      ekont=eij*ekl
8674       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8675 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8676       gcorr_loc(k-1)=gcorr_loc(k-1) &
8677          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8678       if (l.eq.j+1) then
8679         gcorr_loc(l-1)=gcorr_loc(l-1) &
8680            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8681       else
8682         gcorr_loc(j-1)=gcorr_loc(j-1) &
8683            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8684       endif
8685       do iii=1,2
8686         do kkk=1,5
8687           do lll=1,3
8688             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8689                               -EAEAderx(2,2,lll,kkk,iii,1)
8690 !d            derx(lll,kkk,iii)=0.0d0
8691           enddo
8692         enddo
8693       enddo
8694 !d      gcorr_loc(l-1)=0.0d0
8695 !d      gcorr_loc(j-1)=0.0d0
8696 !d      gcorr_loc(k-1)=0.0d0
8697 !d      eel4=1.0d0
8698 !d      write (iout,*)'Contacts have occurred for peptide groups',
8699 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8700 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8701       if (j.lt.nres-1) then
8702         j1=j+1
8703         j2=j-1
8704       else
8705         j1=j-1
8706         j2=j-2
8707       endif
8708       if (l.lt.nres-1) then
8709         l1=l+1
8710         l2=l-1
8711       else
8712         l1=l-1
8713         l2=l-2
8714       endif
8715       do ll=1,3
8716 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8717 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8718         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8719         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8720 !grad        ghalf=0.5d0*ggg1(ll)
8721         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8722         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8723         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8724         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8725         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8726         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8727 !grad        ghalf=0.5d0*ggg2(ll)
8728         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8729         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8730         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8731         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8732         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8733         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8734       enddo
8735 !grad      do m=i+1,j-1
8736 !grad        do ll=1,3
8737 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8738 !grad        enddo
8739 !grad      enddo
8740 !grad      do m=k+1,l-1
8741 !grad        do ll=1,3
8742 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8743 !grad        enddo
8744 !grad      enddo
8745 !grad      do m=i+2,j2
8746 !grad        do ll=1,3
8747 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8748 !grad        enddo
8749 !grad      enddo
8750 !grad      do m=k+2,l2
8751 !grad        do ll=1,3
8752 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8753 !grad        enddo
8754 !grad      enddo
8755 !d      do iii=1,nres-3
8756 !d        write (2,*) iii,gcorr_loc(iii)
8757 !d      enddo
8758       eello4=ekont*eel4
8759 !d      write (2,*) 'ekont',ekont
8760 !d      write (iout,*) 'eello4',ekont*eel4
8761       return
8762       end function eello4
8763 !-----------------------------------------------------------------------------
8764       real(kind=8) function eello5(i,j,k,l,jj,kk)
8765 !      implicit real*8 (a-h,o-z)
8766 !      include 'DIMENSIONS'
8767 !      include 'COMMON.IOUNITS'
8768 !      include 'COMMON.CHAIN'
8769 !      include 'COMMON.DERIV'
8770 !      include 'COMMON.INTERACT'
8771 !      include 'COMMON.CONTACTS'
8772 !      include 'COMMON.TORSION'
8773 !      include 'COMMON.VAR'
8774 !      include 'COMMON.GEO'
8775       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8776       real(kind=8),dimension(2) :: vv
8777       real(kind=8),dimension(3) :: ggg1,ggg2
8778       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8779       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8780       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8781 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8782 !                                                                              C
8783 !                            Parallel chains                                   C
8784 !                                                                              C
8785 !          o             o                   o             o                   C
8786 !         /l\           / \             \   / \           / \   /              C
8787 !        /   \         /   \             \ /   \         /   \ /               C
8788 !       j| o |l1       | o |                o| o |         | o |o                C
8789 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8790 !      \i/   \         /   \ /             /   \         /   \                 C
8791 !       o    k1             o                                                  C
8792 !         (I)          (II)                (III)          (IV)                 C
8793 !                                                                              C
8794 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8795 !                                                                              C
8796 !                            Antiparallel chains                               C
8797 !                                                                              C
8798 !          o             o                   o             o                   C
8799 !         /j\           / \             \   / \           / \   /              C
8800 !        /   \         /   \             \ /   \         /   \ /               C
8801 !      j1| o |l        | o |                o| o |         | o |o                C
8802 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8803 !      \i/   \         /   \ /             /   \         /   \                 C
8804 !       o     k1            o                                                  C
8805 !         (I)          (II)                (III)          (IV)                 C
8806 !                                                                              C
8807 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8808 !                                                                              C
8809 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8810 !                                                                              C
8811 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8812 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8813 !d        eello5=0.0d0
8814 !d        return
8815 !d      endif
8816 !d      write (iout,*)
8817 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8818 !d     &   ' and',k,l
8819       itk=itortyp(itype(k,1))
8820       itl=itortyp(itype(l,1))
8821       itj=itortyp(itype(j,1))
8822       eello5_1=0.0d0
8823       eello5_2=0.0d0
8824       eello5_3=0.0d0
8825       eello5_4=0.0d0
8826 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8827 !d     &   eel5_3_num,eel5_4_num)
8828       do iii=1,2
8829         do kkk=1,5
8830           do lll=1,3
8831             derx(lll,kkk,iii)=0.0d0
8832           enddo
8833         enddo
8834       enddo
8835 !d      eij=facont_hb(jj,i)
8836 !d      ekl=facont_hb(kk,k)
8837 !d      ekont=eij*ekl
8838 !d      write (iout,*)'Contacts have occurred for peptide groups',
8839 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8840 !d      goto 1111
8841 ! Contribution from the graph I.
8842 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8843 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8844       call transpose2(EUg(1,1,k),auxmat(1,1))
8845       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8846       vv(1)=pizda(1,1)-pizda(2,2)
8847       vv(2)=pizda(1,2)+pizda(2,1)
8848       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8849        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8850 ! Explicit gradient in virtual-dihedral angles.
8851       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8852        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8853        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8854       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8855       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8856       vv(1)=pizda(1,1)-pizda(2,2)
8857       vv(2)=pizda(1,2)+pizda(2,1)
8858       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8859        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8860        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8861       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8862       vv(1)=pizda(1,1)-pizda(2,2)
8863       vv(2)=pizda(1,2)+pizda(2,1)
8864       if (l.eq.j+1) then
8865         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8866          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8867          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8868       else
8869         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8870          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8871          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8872       endif
8873 ! Cartesian gradient
8874       do iii=1,2
8875         do kkk=1,5
8876           do lll=1,3
8877             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8878               pizda(1,1))
8879             vv(1)=pizda(1,1)-pizda(2,2)
8880             vv(2)=pizda(1,2)+pizda(2,1)
8881             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8882              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8883              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8884           enddo
8885         enddo
8886       enddo
8887 !      goto 1112
8888 !1111  continue
8889 ! Contribution from graph II
8890       call transpose2(EE(1,1,itk),auxmat(1,1))
8891       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8892       vv(1)=pizda(1,1)+pizda(2,2)
8893       vv(2)=pizda(2,1)-pizda(1,2)
8894       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8895        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8896 ! Explicit gradient in virtual-dihedral angles.
8897       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8898        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8899       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8900       vv(1)=pizda(1,1)+pizda(2,2)
8901       vv(2)=pizda(2,1)-pizda(1,2)
8902       if (l.eq.j+1) then
8903         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8904          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8905          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8906       else
8907         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8908          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8909          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8910       endif
8911 ! Cartesian gradient
8912       do iii=1,2
8913         do kkk=1,5
8914           do lll=1,3
8915             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8916               pizda(1,1))
8917             vv(1)=pizda(1,1)+pizda(2,2)
8918             vv(2)=pizda(2,1)-pizda(1,2)
8919             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8920              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8921              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8922           enddo
8923         enddo
8924       enddo
8925 !d      goto 1112
8926 !d1111  continue
8927       if (l.eq.j+1) then
8928 !d        goto 1110
8929 ! Parallel orientation
8930 ! Contribution from graph III
8931         call transpose2(EUg(1,1,l),auxmat(1,1))
8932         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8933         vv(1)=pizda(1,1)-pizda(2,2)
8934         vv(2)=pizda(1,2)+pizda(2,1)
8935         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8936          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8937 ! Explicit gradient in virtual-dihedral angles.
8938         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8939          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8940          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8941         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8942         vv(1)=pizda(1,1)-pizda(2,2)
8943         vv(2)=pizda(1,2)+pizda(2,1)
8944         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8945          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8946          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8947         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8948         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8949         vv(1)=pizda(1,1)-pizda(2,2)
8950         vv(2)=pizda(1,2)+pizda(2,1)
8951         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8952          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8953          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8954 ! Cartesian gradient
8955         do iii=1,2
8956           do kkk=1,5
8957             do lll=1,3
8958               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8959                 pizda(1,1))
8960               vv(1)=pizda(1,1)-pizda(2,2)
8961               vv(2)=pizda(1,2)+pizda(2,1)
8962               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8963                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8964                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8965             enddo
8966           enddo
8967         enddo
8968 !d        goto 1112
8969 ! Contribution from graph IV
8970 !d1110    continue
8971         call transpose2(EE(1,1,itl),auxmat(1,1))
8972         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8973         vv(1)=pizda(1,1)+pizda(2,2)
8974         vv(2)=pizda(2,1)-pizda(1,2)
8975         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8976          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8977 ! Explicit gradient in virtual-dihedral angles.
8978         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8979          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8980         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8981         vv(1)=pizda(1,1)+pizda(2,2)
8982         vv(2)=pizda(2,1)-pizda(1,2)
8983         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8984          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8985          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8986 ! Cartesian gradient
8987         do iii=1,2
8988           do kkk=1,5
8989             do lll=1,3
8990               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8991                 pizda(1,1))
8992               vv(1)=pizda(1,1)+pizda(2,2)
8993               vv(2)=pizda(2,1)-pizda(1,2)
8994               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8995                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8996                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8997             enddo
8998           enddo
8999         enddo
9000       else
9001 ! Antiparallel orientation
9002 ! Contribution from graph III
9003 !        goto 1110
9004         call transpose2(EUg(1,1,j),auxmat(1,1))
9005         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9006         vv(1)=pizda(1,1)-pizda(2,2)
9007         vv(2)=pizda(1,2)+pizda(2,1)
9008         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9009          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9010 ! Explicit gradient in virtual-dihedral angles.
9011         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9012          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9013          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9014         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9015         vv(1)=pizda(1,1)-pizda(2,2)
9016         vv(2)=pizda(1,2)+pizda(2,1)
9017         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9018          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9019          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9020         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9021         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9022         vv(1)=pizda(1,1)-pizda(2,2)
9023         vv(2)=pizda(1,2)+pizda(2,1)
9024         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9025          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9026          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9027 ! Cartesian gradient
9028         do iii=1,2
9029           do kkk=1,5
9030             do lll=1,3
9031               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9032                 pizda(1,1))
9033               vv(1)=pizda(1,1)-pizda(2,2)
9034               vv(2)=pizda(1,2)+pizda(2,1)
9035               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9036                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9037                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9038             enddo
9039           enddo
9040         enddo
9041 !d        goto 1112
9042 ! Contribution from graph IV
9043 1110    continue
9044         call transpose2(EE(1,1,itj),auxmat(1,1))
9045         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9046         vv(1)=pizda(1,1)+pizda(2,2)
9047         vv(2)=pizda(2,1)-pizda(1,2)
9048         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9049          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9050 ! Explicit gradient in virtual-dihedral angles.
9051         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9052          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9053         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9054         vv(1)=pizda(1,1)+pizda(2,2)
9055         vv(2)=pizda(2,1)-pizda(1,2)
9056         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9057          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9058          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9059 ! Cartesian gradient
9060         do iii=1,2
9061           do kkk=1,5
9062             do lll=1,3
9063               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9064                 pizda(1,1))
9065               vv(1)=pizda(1,1)+pizda(2,2)
9066               vv(2)=pizda(2,1)-pizda(1,2)
9067               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9068                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9069                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9070             enddo
9071           enddo
9072         enddo
9073       endif
9074 1112  continue
9075       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9076 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9077 !d        write (2,*) 'ijkl',i,j,k,l
9078 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9079 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9080 !d      endif
9081 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9082 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9083 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9084 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9085       if (j.lt.nres-1) then
9086         j1=j+1
9087         j2=j-1
9088       else
9089         j1=j-1
9090         j2=j-2
9091       endif
9092       if (l.lt.nres-1) then
9093         l1=l+1
9094         l2=l-1
9095       else
9096         l1=l-1
9097         l2=l-2
9098       endif
9099 !d      eij=1.0d0
9100 !d      ekl=1.0d0
9101 !d      ekont=1.0d0
9102 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9103 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9104 !        summed up outside the subrouine as for the other subroutines
9105 !        handling long-range interactions. The old code is commented out
9106 !        with "cgrad" to keep track of changes.
9107       do ll=1,3
9108 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9109 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9110         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9111         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9112 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9113 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9114 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9115 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9116 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9117 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9118 !     &   gradcorr5ij,
9119 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9120 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9121 !grad        ghalf=0.5d0*ggg1(ll)
9122 !d        ghalf=0.0d0
9123         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9124         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9125         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9126         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9127         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9128         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9129 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9130 !grad        ghalf=0.5d0*ggg2(ll)
9131         ghalf=0.0d0
9132         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9133         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9134         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9135         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9136         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9137         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9138       enddo
9139 !d      goto 1112
9140 !grad      do m=i+1,j-1
9141 !grad        do ll=1,3
9142 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9143 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9144 !grad        enddo
9145 !grad      enddo
9146 !grad      do m=k+1,l-1
9147 !grad        do ll=1,3
9148 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9149 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9150 !grad        enddo
9151 !grad      enddo
9152 !1112  continue
9153 !grad      do m=i+2,j2
9154 !grad        do ll=1,3
9155 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9156 !grad        enddo
9157 !grad      enddo
9158 !grad      do m=k+2,l2
9159 !grad        do ll=1,3
9160 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9161 !grad        enddo
9162 !grad      enddo
9163 !d      do iii=1,nres-3
9164 !d        write (2,*) iii,g_corr5_loc(iii)
9165 !d      enddo
9166       eello5=ekont*eel5
9167 !d      write (2,*) 'ekont',ekont
9168 !d      write (iout,*) 'eello5',ekont*eel5
9169       return
9170       end function eello5
9171 !-----------------------------------------------------------------------------
9172       real(kind=8) function eello6(i,j,k,l,jj,kk)
9173 !      implicit real*8 (a-h,o-z)
9174 !      include 'DIMENSIONS'
9175 !      include 'COMMON.IOUNITS'
9176 !      include 'COMMON.CHAIN'
9177 !      include 'COMMON.DERIV'
9178 !      include 'COMMON.INTERACT'
9179 !      include 'COMMON.CONTACTS'
9180 !      include 'COMMON.TORSION'
9181 !      include 'COMMON.VAR'
9182 !      include 'COMMON.GEO'
9183 !      include 'COMMON.FFIELD'
9184       real(kind=8),dimension(3) :: ggg1,ggg2
9185       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9186                    eello6_6,eel6
9187       real(kind=8) :: gradcorr6ij,gradcorr6kl
9188       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9189 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9190 !d        eello6=0.0d0
9191 !d        return
9192 !d      endif
9193 !d      write (iout,*)
9194 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9195 !d     &   ' and',k,l
9196       eello6_1=0.0d0
9197       eello6_2=0.0d0
9198       eello6_3=0.0d0
9199       eello6_4=0.0d0
9200       eello6_5=0.0d0
9201       eello6_6=0.0d0
9202 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9203 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9204       do iii=1,2
9205         do kkk=1,5
9206           do lll=1,3
9207             derx(lll,kkk,iii)=0.0d0
9208           enddo
9209         enddo
9210       enddo
9211 !d      eij=facont_hb(jj,i)
9212 !d      ekl=facont_hb(kk,k)
9213 !d      ekont=eij*ekl
9214 !d      eij=1.0d0
9215 !d      ekl=1.0d0
9216 !d      ekont=1.0d0
9217       if (l.eq.j+1) then
9218         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9219         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9220         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9221         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9222         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9223         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9224       else
9225         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9226         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9227         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9228         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9229         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9230           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9231         else
9232           eello6_5=0.0d0
9233         endif
9234         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9235       endif
9236 ! If turn contributions are considered, they will be handled separately.
9237       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9238 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9239 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9240 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9241 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9242 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9243 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9244 !d      goto 1112
9245       if (j.lt.nres-1) then
9246         j1=j+1
9247         j2=j-1
9248       else
9249         j1=j-1
9250         j2=j-2
9251       endif
9252       if (l.lt.nres-1) then
9253         l1=l+1
9254         l2=l-1
9255       else
9256         l1=l-1
9257         l2=l-2
9258       endif
9259       do ll=1,3
9260 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9261 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9262 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9263 !grad        ghalf=0.5d0*ggg1(ll)
9264 !d        ghalf=0.0d0
9265         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9266         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9267         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9268         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9269         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9270         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9271         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9272         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9273 !grad        ghalf=0.5d0*ggg2(ll)
9274 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9275 !d        ghalf=0.0d0
9276         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9277         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9278         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9279         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9280         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9281         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9282       enddo
9283 !d      goto 1112
9284 !grad      do m=i+1,j-1
9285 !grad        do ll=1,3
9286 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9287 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9288 !grad        enddo
9289 !grad      enddo
9290 !grad      do m=k+1,l-1
9291 !grad        do ll=1,3
9292 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9293 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9294 !grad        enddo
9295 !grad      enddo
9296 !grad1112  continue
9297 !grad      do m=i+2,j2
9298 !grad        do ll=1,3
9299 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9300 !grad        enddo
9301 !grad      enddo
9302 !grad      do m=k+2,l2
9303 !grad        do ll=1,3
9304 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9305 !grad        enddo
9306 !grad      enddo
9307 !d      do iii=1,nres-3
9308 !d        write (2,*) iii,g_corr6_loc(iii)
9309 !d      enddo
9310       eello6=ekont*eel6
9311 !d      write (2,*) 'ekont',ekont
9312 !d      write (iout,*) 'eello6',ekont*eel6
9313       return
9314       end function eello6
9315 !-----------------------------------------------------------------------------
9316       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9317       use comm_kut
9318 !      implicit real*8 (a-h,o-z)
9319 !      include 'DIMENSIONS'
9320 !      include 'COMMON.IOUNITS'
9321 !      include 'COMMON.CHAIN'
9322 !      include 'COMMON.DERIV'
9323 !      include 'COMMON.INTERACT'
9324 !      include 'COMMON.CONTACTS'
9325 !      include 'COMMON.TORSION'
9326 !      include 'COMMON.VAR'
9327 !      include 'COMMON.GEO'
9328       real(kind=8),dimension(2) :: vv,vv1
9329       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9330       logical :: swap
9331 !el      logical :: lprn
9332 !el      common /kutas/ lprn
9333       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9334       real(kind=8) :: s1,s2,s3,s4,s5
9335 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9336 !                                                                              C
9337 !      Parallel       Antiparallel                                             C
9338 !                                                                              C
9339 !          o             o                                                     C
9340 !         /l\           /j\                                                    C
9341 !        /   \         /   \                                                   C
9342 !       /| o |         | o |\                                                  C
9343 !     \ j|/k\|  /   \  |/k\|l /                                                C
9344 !      \ /   \ /     \ /   \ /                                                 C
9345 !       o     o       o     o                                                  C
9346 !       i             i                                                        C
9347 !                                                                              C
9348 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9349       itk=itortyp(itype(k,1))
9350       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9351       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9352       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9353       call transpose2(EUgC(1,1,k),auxmat(1,1))
9354       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9355       vv1(1)=pizda1(1,1)-pizda1(2,2)
9356       vv1(2)=pizda1(1,2)+pizda1(2,1)
9357       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9358       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9359       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9360       s5=scalar2(vv(1),Dtobr2(1,i))
9361 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9362       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9363       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9364        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9365        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9366        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9367        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9368        +scalar2(vv(1),Dtobr2der(1,i)))
9369       call matmat2(AEAderg(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       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9373       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9374       if (l.eq.j+1) then
9375         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9376        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9377        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9378        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9379        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9380       else
9381         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9382        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9383        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9384        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9385        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9386       endif
9387       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9388       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9389       vv1(1)=pizda1(1,1)-pizda1(2,2)
9390       vv1(2)=pizda1(1,2)+pizda1(2,1)
9391       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9392        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9393        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9394        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9395       do iii=1,2
9396         if (swap) then
9397           ind=3-iii
9398         else
9399           ind=iii
9400         endif
9401         do kkk=1,5
9402           do lll=1,3
9403             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9404             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9405             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9406             call transpose2(EUgC(1,1,k),auxmat(1,1))
9407             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9408               pizda1(1,1))
9409             vv1(1)=pizda1(1,1)-pizda1(2,2)
9410             vv1(2)=pizda1(1,2)+pizda1(2,1)
9411             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9412             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9413              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9414             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9415              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9416             s5=scalar2(vv(1),Dtobr2(1,i))
9417             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9418           enddo
9419         enddo
9420       enddo
9421       return
9422       end function eello6_graph1
9423 !-----------------------------------------------------------------------------
9424       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9425       use comm_kut
9426 !      implicit real*8 (a-h,o-z)
9427 !      include 'DIMENSIONS'
9428 !      include 'COMMON.IOUNITS'
9429 !      include 'COMMON.CHAIN'
9430 !      include 'COMMON.DERIV'
9431 !      include 'COMMON.INTERACT'
9432 !      include 'COMMON.CONTACTS'
9433 !      include 'COMMON.TORSION'
9434 !      include 'COMMON.VAR'
9435 !      include 'COMMON.GEO'
9436       logical :: swap
9437       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9438       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9439 !el      logical :: lprn
9440 !el      common /kutas/ lprn
9441       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9442       real(kind=8) :: s2,s3,s4
9443 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9444 !                                                                              C
9445 !      Parallel       Antiparallel                                             C
9446 !                                                                              C
9447 !          o             o                                                     C
9448 !     \   /l\           /j\   /                                                C
9449 !      \ /   \         /   \ /                                                 C
9450 !       o| o |         | o |o                                                  C
9451 !     \ j|/k\|      \  |/k\|l                                                  C
9452 !      \ /   \       \ /   \                                                   C
9453 !       o             o                                                        C
9454 !       i             i                                                        C
9455 !                                                                              C
9456 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9457 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9458 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9459 !           but not in a cluster cumulant
9460 #ifdef MOMENT
9461       s1=dip(1,jj,i)*dip(1,kk,k)
9462 #endif
9463       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9464       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9465       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9466       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9467       call transpose2(EUg(1,1,k),auxmat(1,1))
9468       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9469       vv(1)=pizda(1,1)-pizda(2,2)
9470       vv(2)=pizda(1,2)+pizda(2,1)
9471       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9472 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9473 #ifdef MOMENT
9474       eello6_graph2=-(s1+s2+s3+s4)
9475 #else
9476       eello6_graph2=-(s2+s3+s4)
9477 #endif
9478 !      eello6_graph2=-s3
9479 ! Derivatives in gamma(i-1)
9480       if (i.gt.1) then
9481 #ifdef MOMENT
9482         s1=dipderg(1,jj,i)*dip(1,kk,k)
9483 #endif
9484         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9485         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9486         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9487         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9488 #ifdef MOMENT
9489         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9490 #else
9491         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9492 #endif
9493 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9494       endif
9495 ! Derivatives in gamma(k-1)
9496 #ifdef MOMENT
9497       s1=dip(1,jj,i)*dipderg(1,kk,k)
9498 #endif
9499       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9500       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9501       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9502       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9503       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9504       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9505       vv(1)=pizda(1,1)-pizda(2,2)
9506       vv(2)=pizda(1,2)+pizda(2,1)
9507       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9508 #ifdef MOMENT
9509       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9510 #else
9511       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9512 #endif
9513 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9514 ! Derivatives in gamma(j-1) or gamma(l-1)
9515       if (j.gt.1) then
9516 #ifdef MOMENT
9517         s1=dipderg(3,jj,i)*dip(1,kk,k)
9518 #endif
9519         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9520         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9521         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9522         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9523         vv(1)=pizda(1,1)-pizda(2,2)
9524         vv(2)=pizda(1,2)+pizda(2,1)
9525         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9526 #ifdef MOMENT
9527         if (swap) then
9528           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9529         else
9530           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9531         endif
9532 #endif
9533         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9534 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9535       endif
9536 ! Derivatives in gamma(l-1) or gamma(j-1)
9537       if (l.gt.1) then
9538 #ifdef MOMENT
9539         s1=dip(1,jj,i)*dipderg(3,kk,k)
9540 #endif
9541         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9542         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9543         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9544         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9545         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9546         vv(1)=pizda(1,1)-pizda(2,2)
9547         vv(2)=pizda(1,2)+pizda(2,1)
9548         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9549 #ifdef MOMENT
9550         if (swap) then
9551           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9552         else
9553           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9554         endif
9555 #endif
9556         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9557 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9558       endif
9559 ! Cartesian derivatives.
9560       if (lprn) then
9561         write (2,*) 'In eello6_graph2'
9562         do iii=1,2
9563           write (2,*) 'iii=',iii
9564           do kkk=1,5
9565             write (2,*) 'kkk=',kkk
9566             do jjj=1,2
9567               write (2,'(3(2f10.5),5x)') &
9568               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9569             enddo
9570           enddo
9571         enddo
9572       endif
9573       do iii=1,2
9574         do kkk=1,5
9575           do lll=1,3
9576 #ifdef MOMENT
9577             if (iii.eq.1) then
9578               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9579             else
9580               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9581             endif
9582 #endif
9583             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9584               auxvec(1))
9585             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9586             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9587               auxvec(1))
9588             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9589             call transpose2(EUg(1,1,k),auxmat(1,1))
9590             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9591               pizda(1,1))
9592             vv(1)=pizda(1,1)-pizda(2,2)
9593             vv(2)=pizda(1,2)+pizda(2,1)
9594             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9595 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9596 #ifdef MOMENT
9597             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9598 #else
9599             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9600 #endif
9601             if (swap) then
9602               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9603             else
9604               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9605             endif
9606           enddo
9607         enddo
9608       enddo
9609       return
9610       end function eello6_graph2
9611 !-----------------------------------------------------------------------------
9612       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9613 !      implicit real*8 (a-h,o-z)
9614 !      include 'DIMENSIONS'
9615 !      include 'COMMON.IOUNITS'
9616 !      include 'COMMON.CHAIN'
9617 !      include 'COMMON.DERIV'
9618 !      include 'COMMON.INTERACT'
9619 !      include 'COMMON.CONTACTS'
9620 !      include 'COMMON.TORSION'
9621 !      include 'COMMON.VAR'
9622 !      include 'COMMON.GEO'
9623       real(kind=8),dimension(2) :: vv,auxvec
9624       real(kind=8),dimension(2,2) :: pizda,auxmat
9625       logical :: swap
9626       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9627       real(kind=8) :: s1,s2,s3,s4
9628 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9629 !                                                                              C
9630 !      Parallel       Antiparallel                                             C
9631 !                                                                              C
9632 !          o             o                                                     C
9633 !         /l\   /   \   /j\                                                    C
9634 !        /   \ /     \ /   \                                                   C
9635 !       /| o |o       o| o |\                                                  C
9636 !       j|/k\|  /      |/k\|l /                                                C
9637 !        /   \ /       /   \ /                                                 C
9638 !       /     o       /     o                                                  C
9639 !       i             i                                                        C
9640 !                                                                              C
9641 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9642 !
9643 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9644 !           energy moment and not to the cluster cumulant.
9645       iti=itortyp(itype(i,1))
9646       if (j.lt.nres-1) then
9647         itj1=itortyp(itype(j+1,1))
9648       else
9649         itj1=ntortyp+1
9650       endif
9651       itk=itortyp(itype(k,1))
9652       itk1=itortyp(itype(k+1,1))
9653       if (l.lt.nres-1) then
9654         itl1=itortyp(itype(l+1,1))
9655       else
9656         itl1=ntortyp+1
9657       endif
9658 #ifdef MOMENT
9659       s1=dip(4,jj,i)*dip(4,kk,k)
9660 #endif
9661       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9662       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9663       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9664       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9665       call transpose2(EE(1,1,itk),auxmat(1,1))
9666       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9667       vv(1)=pizda(1,1)+pizda(2,2)
9668       vv(2)=pizda(2,1)-pizda(1,2)
9669       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9670 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9671 !d     & "sum",-(s2+s3+s4)
9672 #ifdef MOMENT
9673       eello6_graph3=-(s1+s2+s3+s4)
9674 #else
9675       eello6_graph3=-(s2+s3+s4)
9676 #endif
9677 !      eello6_graph3=-s4
9678 ! Derivatives in gamma(k-1)
9679       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9680       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9681       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9682       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9683 ! Derivatives in gamma(l-1)
9684       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9685       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9686       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9687       vv(1)=pizda(1,1)+pizda(2,2)
9688       vv(2)=pizda(2,1)-pizda(1,2)
9689       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9690       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9691 ! Cartesian derivatives.
9692       do iii=1,2
9693         do kkk=1,5
9694           do lll=1,3
9695 #ifdef MOMENT
9696             if (iii.eq.1) then
9697               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9698             else
9699               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9700             endif
9701 #endif
9702             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9703               auxvec(1))
9704             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9705             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9706               auxvec(1))
9707             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9708             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9709               pizda(1,1))
9710             vv(1)=pizda(1,1)+pizda(2,2)
9711             vv(2)=pizda(2,1)-pizda(1,2)
9712             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9713 #ifdef MOMENT
9714             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9715 #else
9716             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9717 #endif
9718             if (swap) then
9719               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9720             else
9721               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9722             endif
9723 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9724           enddo
9725         enddo
9726       enddo
9727       return
9728       end function eello6_graph3
9729 !-----------------------------------------------------------------------------
9730       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9731 !      implicit real*8 (a-h,o-z)
9732 !      include 'DIMENSIONS'
9733 !      include 'COMMON.IOUNITS'
9734 !      include 'COMMON.CHAIN'
9735 !      include 'COMMON.DERIV'
9736 !      include 'COMMON.INTERACT'
9737 !      include 'COMMON.CONTACTS'
9738 !      include 'COMMON.TORSION'
9739 !      include 'COMMON.VAR'
9740 !      include 'COMMON.GEO'
9741 !      include 'COMMON.FFIELD'
9742       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9743       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9744       logical :: swap
9745       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9746               iii,kkk,lll
9747       real(kind=8) :: s1,s2,s3,s4
9748 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9749 !                                                                              C
9750 !      Parallel       Antiparallel                                             C
9751 !                                                                              C
9752 !          o             o                                                     C
9753 !         /l\   /   \   /j\                                                    C
9754 !        /   \ /     \ /   \                                                   C
9755 !       /| o |o       o| o |\                                                  C
9756 !     \ j|/k\|      \  |/k\|l                                                  C
9757 !      \ /   \       \ /   \                                                   C
9758 !       o     \       o     \                                                  C
9759 !       i             i                                                        C
9760 !                                                                              C
9761 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9762 !
9763 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9764 !           energy moment and not to the cluster cumulant.
9765 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9766       iti=itortyp(itype(i,1))
9767       itj=itortyp(itype(j,1))
9768       if (j.lt.nres-1) then
9769         itj1=itortyp(itype(j+1,1))
9770       else
9771         itj1=ntortyp+1
9772       endif
9773       itk=itortyp(itype(k,1))
9774       if (k.lt.nres-1) then
9775         itk1=itortyp(itype(k+1,1))
9776       else
9777         itk1=ntortyp+1
9778       endif
9779       itl=itortyp(itype(l,1))
9780       if (l.lt.nres-1) then
9781         itl1=itortyp(itype(l+1,1))
9782       else
9783         itl1=ntortyp+1
9784       endif
9785 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9786 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9787 !d     & ' itl',itl,' itl1',itl1
9788 #ifdef MOMENT
9789       if (imat.eq.1) then
9790         s1=dip(3,jj,i)*dip(3,kk,k)
9791       else
9792         s1=dip(2,jj,j)*dip(2,kk,l)
9793       endif
9794 #endif
9795       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9796       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9797       if (j.eq.l+1) then
9798         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9799         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9800       else
9801         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9802         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9803       endif
9804       call transpose2(EUg(1,1,k),auxmat(1,1))
9805       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9806       vv(1)=pizda(1,1)-pizda(2,2)
9807       vv(2)=pizda(2,1)+pizda(1,2)
9808       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9809 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9810 #ifdef MOMENT
9811       eello6_graph4=-(s1+s2+s3+s4)
9812 #else
9813       eello6_graph4=-(s2+s3+s4)
9814 #endif
9815 ! Derivatives in gamma(i-1)
9816       if (i.gt.1) then
9817 #ifdef MOMENT
9818         if (imat.eq.1) then
9819           s1=dipderg(2,jj,i)*dip(3,kk,k)
9820         else
9821           s1=dipderg(4,jj,j)*dip(2,kk,l)
9822         endif
9823 #endif
9824         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9825         if (j.eq.l+1) then
9826           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9827           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9828         else
9829           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9830           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9831         endif
9832         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9833         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9834 !d          write (2,*) 'turn6 derivatives'
9835 #ifdef MOMENT
9836           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9837 #else
9838           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9839 #endif
9840         else
9841 #ifdef MOMENT
9842           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9843 #else
9844           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9845 #endif
9846         endif
9847       endif
9848 ! Derivatives in gamma(k-1)
9849 #ifdef MOMENT
9850       if (imat.eq.1) then
9851         s1=dip(3,jj,i)*dipderg(2,kk,k)
9852       else
9853         s1=dip(2,jj,j)*dipderg(4,kk,l)
9854       endif
9855 #endif
9856       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9857       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9858       if (j.eq.l+1) then
9859         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9860         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9861       else
9862         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9863         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9864       endif
9865       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9866       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9867       vv(1)=pizda(1,1)-pizda(2,2)
9868       vv(2)=pizda(2,1)+pizda(1,2)
9869       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9870       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9871 #ifdef MOMENT
9872         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9873 #else
9874         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9875 #endif
9876       else
9877 #ifdef MOMENT
9878         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9879 #else
9880         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9881 #endif
9882       endif
9883 ! Derivatives in gamma(j-1) or gamma(l-1)
9884       if (l.eq.j+1 .and. l.gt.1) then
9885         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9886         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9887         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9888         vv(1)=pizda(1,1)-pizda(2,2)
9889         vv(2)=pizda(2,1)+pizda(1,2)
9890         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9891         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9892       else if (j.gt.1) then
9893         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9894         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9895         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9896         vv(1)=pizda(1,1)-pizda(2,2)
9897         vv(2)=pizda(2,1)+pizda(1,2)
9898         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9899         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9900           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9901         else
9902           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9903         endif
9904       endif
9905 ! Cartesian derivatives.
9906       do iii=1,2
9907         do kkk=1,5
9908           do lll=1,3
9909 #ifdef MOMENT
9910             if (iii.eq.1) then
9911               if (imat.eq.1) then
9912                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9913               else
9914                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9915               endif
9916             else
9917               if (imat.eq.1) then
9918                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9919               else
9920                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9921               endif
9922             endif
9923 #endif
9924             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9925               auxvec(1))
9926             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9927             if (j.eq.l+1) then
9928               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9929                 b1(1,itj1),auxvec(1))
9930               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9931             else
9932               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9933                 b1(1,itl1),auxvec(1))
9934               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9935             endif
9936             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9937               pizda(1,1))
9938             vv(1)=pizda(1,1)-pizda(2,2)
9939             vv(2)=pizda(2,1)+pizda(1,2)
9940             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9941             if (swap) then
9942               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9943 #ifdef MOMENT
9944                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9945                    -(s1+s2+s4)
9946 #else
9947                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9948                    -(s2+s4)
9949 #endif
9950                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9951               else
9952 #ifdef MOMENT
9953                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9954 #else
9955                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9956 #endif
9957                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9958               endif
9959             else
9960 #ifdef MOMENT
9961               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9962 #else
9963               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9964 #endif
9965               if (l.eq.j+1) then
9966                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9967               else
9968                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9969               endif
9970             endif
9971           enddo
9972         enddo
9973       enddo
9974       return
9975       end function eello6_graph4
9976 !-----------------------------------------------------------------------------
9977       real(kind=8) function eello_turn6(i,jj,kk)
9978 !      implicit real*8 (a-h,o-z)
9979 !      include 'DIMENSIONS'
9980 !      include 'COMMON.IOUNITS'
9981 !      include 'COMMON.CHAIN'
9982 !      include 'COMMON.DERIV'
9983 !      include 'COMMON.INTERACT'
9984 !      include 'COMMON.CONTACTS'
9985 !      include 'COMMON.TORSION'
9986 !      include 'COMMON.VAR'
9987 !      include 'COMMON.GEO'
9988       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9989       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9990       real(kind=8),dimension(3) :: ggg1,ggg2
9991       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9992       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9993 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9994 !           the respective energy moment and not to the cluster cumulant.
9995 !el local variables
9996       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9997       integer :: j1,j2,l1,l2,ll
9998       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9999       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10000       s1=0.0d0
10001       s8=0.0d0
10002       s13=0.0d0
10003 !
10004       eello_turn6=0.0d0
10005       j=i+4
10006       k=i+1
10007       l=i+3
10008       iti=itortyp(itype(i,1))
10009       itk=itortyp(itype(k,1))
10010       itk1=itortyp(itype(k+1,1))
10011       itl=itortyp(itype(l,1))
10012       itj=itortyp(itype(j,1))
10013 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10014 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10015 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10016 !d        eello6=0.0d0
10017 !d        return
10018 !d      endif
10019 !d      write (iout,*)
10020 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10021 !d     &   ' and',k,l
10022 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10023       do iii=1,2
10024         do kkk=1,5
10025           do lll=1,3
10026             derx_turn(lll,kkk,iii)=0.0d0
10027           enddo
10028         enddo
10029       enddo
10030 !d      eij=1.0d0
10031 !d      ekl=1.0d0
10032 !d      ekont=1.0d0
10033       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10034 !d      eello6_5=0.0d0
10035 !d      write (2,*) 'eello6_5',eello6_5
10036 #ifdef MOMENT
10037       call transpose2(AEA(1,1,1),auxmat(1,1))
10038       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10039       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10040       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10041 #endif
10042       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10043       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10044       s2 = scalar2(b1(1,itk),vtemp1(1))
10045 #ifdef MOMENT
10046       call transpose2(AEA(1,1,2),atemp(1,1))
10047       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10048       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10049       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10050 #endif
10051       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10052       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10053       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10054 #ifdef MOMENT
10055       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10056       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10057       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10058       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10059       ss13 = scalar2(b1(1,itk),vtemp4(1))
10060       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10061 #endif
10062 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10063 !      s1=0.0d0
10064 !      s2=0.0d0
10065 !      s8=0.0d0
10066 !      s12=0.0d0
10067 !      s13=0.0d0
10068       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10069 ! Derivatives in gamma(i+2)
10070       s1d =0.0d0
10071       s8d =0.0d0
10072 #ifdef MOMENT
10073       call transpose2(AEA(1,1,1),auxmatd(1,1))
10074       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10075       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10076       call transpose2(AEAderg(1,1,2),atempd(1,1))
10077       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10078       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10079 #endif
10080       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10081       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10082       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10083 !      s1d=0.0d0
10084 !      s2d=0.0d0
10085 !      s8d=0.0d0
10086 !      s12d=0.0d0
10087 !      s13d=0.0d0
10088       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10089 ! Derivatives in gamma(i+3)
10090 #ifdef MOMENT
10091       call transpose2(AEA(1,1,1),auxmatd(1,1))
10092       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10093       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10094       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10095 #endif
10096       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10097       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10098       s2d = scalar2(b1(1,itk),vtemp1d(1))
10099 #ifdef MOMENT
10100       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10101       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10102 #endif
10103       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10104 #ifdef MOMENT
10105       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10106       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10107       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10108 #endif
10109 !      s1d=0.0d0
10110 !      s2d=0.0d0
10111 !      s8d=0.0d0
10112 !      s12d=0.0d0
10113 !      s13d=0.0d0
10114 #ifdef MOMENT
10115       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10116                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10117 #else
10118       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10119                     -0.5d0*ekont*(s2d+s12d)
10120 #endif
10121 ! Derivatives in gamma(i+4)
10122       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10123       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10124       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10125 #ifdef MOMENT
10126       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10127       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10128       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10129 #endif
10130 !      s1d=0.0d0
10131 !      s2d=0.0d0
10132 !      s8d=0.0d0
10133 !      s12d=0.0d0
10134 !      s13d=0.0d0
10135 #ifdef MOMENT
10136       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10137 #else
10138       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10139 #endif
10140 ! Derivatives in gamma(i+5)
10141 #ifdef MOMENT
10142       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10143       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10144       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10145 #endif
10146       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10147       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10148       s2d = scalar2(b1(1,itk),vtemp1d(1))
10149 #ifdef MOMENT
10150       call transpose2(AEA(1,1,2),atempd(1,1))
10151       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10152       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10153 #endif
10154       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10155       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10156 #ifdef MOMENT
10157       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10158       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10159       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10160 #endif
10161 !      s1d=0.0d0
10162 !      s2d=0.0d0
10163 !      s8d=0.0d0
10164 !      s12d=0.0d0
10165 !      s13d=0.0d0
10166 #ifdef MOMENT
10167       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10168                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10169 #else
10170       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10171                     -0.5d0*ekont*(s2d+s12d)
10172 #endif
10173 ! Cartesian derivatives
10174       do iii=1,2
10175         do kkk=1,5
10176           do lll=1,3
10177 #ifdef MOMENT
10178             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10179             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10180             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10181 #endif
10182             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10183             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10184                 vtemp1d(1))
10185             s2d = scalar2(b1(1,itk),vtemp1d(1))
10186 #ifdef MOMENT
10187             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10188             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10189             s8d = -(atempd(1,1)+atempd(2,2))* &
10190                  scalar2(cc(1,1,itl),vtemp2(1))
10191 #endif
10192             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10193                  auxmatd(1,1))
10194             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10195             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10196 !      s1d=0.0d0
10197 !      s2d=0.0d0
10198 !      s8d=0.0d0
10199 !      s12d=0.0d0
10200 !      s13d=0.0d0
10201 #ifdef MOMENT
10202             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10203               - 0.5d0*(s1d+s2d)
10204 #else
10205             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10206               - 0.5d0*s2d
10207 #endif
10208 #ifdef MOMENT
10209             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10210               - 0.5d0*(s8d+s12d)
10211 #else
10212             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10213               - 0.5d0*s12d
10214 #endif
10215           enddo
10216         enddo
10217       enddo
10218 #ifdef MOMENT
10219       do kkk=1,5
10220         do lll=1,3
10221           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10222             achuj_tempd(1,1))
10223           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10224           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10225           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10226           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10227           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10228             vtemp4d(1))
10229           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10230           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10231           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10232         enddo
10233       enddo
10234 #endif
10235 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10236 !d     &  16*eel_turn6_num
10237 !d      goto 1112
10238       if (j.lt.nres-1) then
10239         j1=j+1
10240         j2=j-1
10241       else
10242         j1=j-1
10243         j2=j-2
10244       endif
10245       if (l.lt.nres-1) then
10246         l1=l+1
10247         l2=l-1
10248       else
10249         l1=l-1
10250         l2=l-2
10251       endif
10252       do ll=1,3
10253 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10254 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10255 !grad        ghalf=0.5d0*ggg1(ll)
10256 !d        ghalf=0.0d0
10257         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10258         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10259         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10260           +ekont*derx_turn(ll,2,1)
10261         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10262         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10263           +ekont*derx_turn(ll,4,1)
10264         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10265         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10266         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10267 !grad        ghalf=0.5d0*ggg2(ll)
10268 !d        ghalf=0.0d0
10269         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10270           +ekont*derx_turn(ll,2,2)
10271         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10272         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10273           +ekont*derx_turn(ll,4,2)
10274         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10275         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10276         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10277       enddo
10278 !d      goto 1112
10279 !grad      do m=i+1,j-1
10280 !grad        do ll=1,3
10281 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10282 !grad        enddo
10283 !grad      enddo
10284 !grad      do m=k+1,l-1
10285 !grad        do ll=1,3
10286 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10287 !grad        enddo
10288 !grad      enddo
10289 !grad1112  continue
10290 !grad      do m=i+2,j2
10291 !grad        do ll=1,3
10292 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10293 !grad        enddo
10294 !grad      enddo
10295 !grad      do m=k+2,l2
10296 !grad        do ll=1,3
10297 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10298 !grad        enddo
10299 !grad      enddo
10300 !d      do iii=1,nres-3
10301 !d        write (2,*) iii,g_corr6_loc(iii)
10302 !d      enddo
10303       eello_turn6=ekont*eel_turn6
10304 !d      write (2,*) 'ekont',ekont
10305 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10306       return
10307       end function eello_turn6
10308 !-----------------------------------------------------------------------------
10309       subroutine MATVEC2(A1,V1,V2)
10310 !DIR$ INLINEALWAYS MATVEC2
10311 #ifndef OSF
10312 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10313 #endif
10314 !      implicit real*8 (a-h,o-z)
10315 !      include 'DIMENSIONS'
10316       real(kind=8),dimension(2) :: V1,V2
10317       real(kind=8),dimension(2,2) :: A1
10318       real(kind=8) :: vaux1,vaux2
10319 !      DO 1 I=1,2
10320 !        VI=0.0
10321 !        DO 3 K=1,2
10322 !    3     VI=VI+A1(I,K)*V1(K)
10323 !        Vaux(I)=VI
10324 !    1 CONTINUE
10325
10326       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10327       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10328
10329       v2(1)=vaux1
10330       v2(2)=vaux2
10331       end subroutine MATVEC2
10332 !-----------------------------------------------------------------------------
10333       subroutine MATMAT2(A1,A2,A3)
10334 #ifndef OSF
10335 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10336 #endif
10337 !      implicit real*8 (a-h,o-z)
10338 !      include 'DIMENSIONS'
10339       real(kind=8),dimension(2,2) :: A1,A2,A3
10340       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10341 !      DIMENSION AI3(2,2)
10342 !        DO  J=1,2
10343 !          A3IJ=0.0
10344 !          DO K=1,2
10345 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10346 !          enddo
10347 !          A3(I,J)=A3IJ
10348 !       enddo
10349 !      enddo
10350
10351       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10352       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10353       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10354       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10355
10356       A3(1,1)=AI3_11
10357       A3(2,1)=AI3_21
10358       A3(1,2)=AI3_12
10359       A3(2,2)=AI3_22
10360       end subroutine MATMAT2
10361 !-----------------------------------------------------------------------------
10362       real(kind=8) function scalar2(u,v)
10363 !DIR$ INLINEALWAYS scalar2
10364       implicit none
10365       real(kind=8),dimension(2) :: u,v
10366       real(kind=8) :: sc
10367       integer :: i
10368       scalar2=u(1)*v(1)+u(2)*v(2)
10369       return
10370       end function scalar2
10371 !-----------------------------------------------------------------------------
10372       subroutine transpose2(a,at)
10373 !DIR$ INLINEALWAYS transpose2
10374 #ifndef OSF
10375 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10376 #endif
10377       implicit none
10378       real(kind=8),dimension(2,2) :: a,at
10379       at(1,1)=a(1,1)
10380       at(1,2)=a(2,1)
10381       at(2,1)=a(1,2)
10382       at(2,2)=a(2,2)
10383       return
10384       end subroutine transpose2
10385 !-----------------------------------------------------------------------------
10386       subroutine transpose(n,a,at)
10387       implicit none
10388       integer :: n,i,j
10389       real(kind=8),dimension(n,n) :: a,at
10390       do i=1,n
10391         do j=1,n
10392           at(j,i)=a(i,j)
10393         enddo
10394       enddo
10395       return
10396       end subroutine transpose
10397 !-----------------------------------------------------------------------------
10398       subroutine prodmat3(a1,a2,kk,transp,prod)
10399 !DIR$ INLINEALWAYS prodmat3
10400 #ifndef OSF
10401 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10402 #endif
10403       implicit none
10404       integer :: i,j
10405       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10406       logical :: transp
10407 !rc      double precision auxmat(2,2),prod_(2,2)
10408
10409       if (transp) then
10410 !rc        call transpose2(kk(1,1),auxmat(1,1))
10411 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10412 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10413
10414            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10415        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10416            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10417        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10418            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10419        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10420            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10421        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10422
10423       else
10424 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10425 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10426
10427            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10428         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10429            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10430         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10431            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10432         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10433            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10434         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10435
10436       endif
10437 !      call transpose2(a2(1,1),a2t(1,1))
10438
10439 !rc      print *,transp
10440 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10441 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10442
10443       return
10444       end subroutine prodmat3
10445 !-----------------------------------------------------------------------------
10446 ! energy_p_new_barrier.F
10447 !-----------------------------------------------------------------------------
10448       subroutine sum_gradient
10449 !      implicit real*8 (a-h,o-z)
10450       use io_base, only: pdbout
10451 !      include 'DIMENSIONS'
10452 #ifndef ISNAN
10453       external proc_proc
10454 #ifdef WINPGI
10455 !MS$ATTRIBUTES C ::  proc_proc
10456 #endif
10457 #endif
10458 #ifdef MPI
10459       include 'mpif.h'
10460 #endif
10461       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10462                    gloc_scbuf !(3,maxres)
10463
10464       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10465 !#endif
10466 !el local variables
10467       integer :: i,j,k,ierror,ierr
10468       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10469                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10470                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10471                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10472                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10473                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10474                    gsccorr_max,gsccorrx_max,time00
10475
10476 !      include 'COMMON.SETUP'
10477 !      include 'COMMON.IOUNITS'
10478 !      include 'COMMON.FFIELD'
10479 !      include 'COMMON.DERIV'
10480 !      include 'COMMON.INTERACT'
10481 !      include 'COMMON.SBRIDGE'
10482 !      include 'COMMON.CHAIN'
10483 !      include 'COMMON.VAR'
10484 !      include 'COMMON.CONTROL'
10485 !      include 'COMMON.TIME1'
10486 !      include 'COMMON.MAXGRAD'
10487 !      include 'COMMON.SCCOR'
10488 #ifdef TIMING
10489       time01=MPI_Wtime()
10490 #endif
10491 #ifdef DEBUG
10492       write (iout,*) "sum_gradient gvdwc, gvdwx"
10493       do i=1,nres
10494         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10495          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10496       enddo
10497       call flush(iout)
10498 #endif
10499 #ifdef MPI
10500         gradbufc=0.0d0
10501         gradbufx=0.0d0
10502         gradbufc_sum=0.0d0
10503         gloc_scbuf=0.0d0
10504         glocbuf=0.0d0
10505 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10506         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10507           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10508 #endif
10509 !
10510 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10511 !            in virtual-bond-vector coordinates
10512 !
10513 #ifdef DEBUG
10514 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10515 !      do i=1,nres-1
10516 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10517 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10518 !      enddo
10519 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10520 !      do i=1,nres-1
10521 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10522 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10523 !      enddo
10524       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10525       do i=1,nres
10526         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10527          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10528          (gvdwc_scpp(j,i),j=1,3)
10529       enddo
10530       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10531       do i=1,nres
10532         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10533          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10534          (gelc_loc_long(j,i),j=1,3)
10535       enddo
10536       call flush(iout)
10537 #endif
10538 #ifdef SPLITELE
10539       do i=0,nct
10540         do j=1,3
10541           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10542                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10543                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10544                       wel_loc*gel_loc_long(j,i)+ &
10545                       wcorr*gradcorr_long(j,i)+ &
10546                       wcorr5*gradcorr5_long(j,i)+ &
10547                       wcorr6*gradcorr6_long(j,i)+ &
10548                       wturn6*gcorr6_turn_long(j,i)+ &
10549                       wstrain*ghpbc(j,i) &
10550                      +wliptran*gliptranc(j,i) &
10551                      +gradafm(j,i) &
10552                      +welec*gshieldc(j,i) &
10553                      +wcorr*gshieldc_ec(j,i) &
10554                      +wturn3*gshieldc_t3(j,i)&
10555                      +wturn4*gshieldc_t4(j,i)&
10556                      +wel_loc*gshieldc_ll(j,i)&
10557                      +wtube*gg_tube(j,i) &
10558                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10559                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10560                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10561                      wcorr_nucl*gradcorr_nucl(j,i)&
10562                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10563                      wcatprot* gradpepcat(j,i)+ &
10564                      wcatcat*gradcatcat(j,i)+   &
10565                      wscbase*gvdwc_scbase(j,i)+ &
10566                      wpepbase*gvdwc_pepbase(j,i)+&
10567                      wscpho*gvdwc_scpho(j,i)+   &
10568                      wpeppho*gvdwc_peppho(j,i)
10569
10570
10571
10572
10573
10574         enddo
10575       enddo
10576 #else
10577       do i=0,nct
10578         do j=1,3
10579           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10580                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10581                       welec*gelc_long(j,i)+ &
10582                       wbond*gradb(j,i)+ &
10583                       wel_loc*gel_loc_long(j,i)+ &
10584                       wcorr*gradcorr_long(j,i)+ &
10585                       wcorr5*gradcorr5_long(j,i)+ &
10586                       wcorr6*gradcorr6_long(j,i)+ &
10587                       wturn6*gcorr6_turn_long(j,i)+ &
10588                       wstrain*ghpbc(j,i) &
10589                      +wliptran*gliptranc(j,i) &
10590                      +gradafm(j,i) &
10591                      +welec*gshieldc(j,i)&
10592                      +wcorr*gshieldc_ec(j,i) &
10593                      +wturn4*gshieldc_t4(j,i) &
10594                      +wel_loc*gshieldc_ll(j,i)&
10595                      +wtube*gg_tube(j,i) &
10596                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10597                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10598                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10599                      wcorr_nucl*gradcorr_nucl(j,i) &
10600                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10601                      wcatprot* gradpepcat(j,i)+ &
10602                      wcatcat*gradcatcat(j,i)+   &
10603                      wscbase*gvdwc_scbase(j,i)  &
10604                      wpepbase*gvdwc_pepbase(j,i)+&
10605                      wscpho*gvdwc_scpho(j,i)+&
10606                      wpeppho*gvdwc_peppho(j,i)
10607
10608
10609         enddo
10610       enddo
10611 #endif
10612 #ifdef MPI
10613       if (nfgtasks.gt.1) then
10614       time00=MPI_Wtime()
10615 #ifdef DEBUG
10616       write (iout,*) "gradbufc before allreduce"
10617       do i=1,nres
10618         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10619       enddo
10620       call flush(iout)
10621 #endif
10622       do i=0,nres
10623         do j=1,3
10624           gradbufc_sum(j,i)=gradbufc(j,i)
10625         enddo
10626       enddo
10627 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10628 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10629 !      time_reduce=time_reduce+MPI_Wtime()-time00
10630 #ifdef DEBUG
10631 !      write (iout,*) "gradbufc_sum after allreduce"
10632 !      do i=1,nres
10633 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10634 !      enddo
10635 !      call flush(iout)
10636 #endif
10637 #ifdef TIMING
10638 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10639 #endif
10640       do i=0,nres
10641         do k=1,3
10642           gradbufc(k,i)=0.0d0
10643         enddo
10644       enddo
10645 #ifdef DEBUG
10646       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10647       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10648                         " jgrad_end  ",jgrad_end(i),&
10649                         i=igrad_start,igrad_end)
10650 #endif
10651 !
10652 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10653 ! do not parallelize this part.
10654 !
10655 !      do i=igrad_start,igrad_end
10656 !        do j=jgrad_start(i),jgrad_end(i)
10657 !          do k=1,3
10658 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10659 !          enddo
10660 !        enddo
10661 !      enddo
10662       do j=1,3
10663         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10664       enddo
10665       do i=nres-2,-1,-1
10666         do j=1,3
10667           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10668         enddo
10669       enddo
10670 #ifdef DEBUG
10671       write (iout,*) "gradbufc after summing"
10672       do i=1,nres
10673         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10674       enddo
10675       call flush(iout)
10676 #endif
10677       else
10678 #endif
10679 !el#define DEBUG
10680 #ifdef DEBUG
10681       write (iout,*) "gradbufc"
10682       do i=1,nres
10683         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10684       enddo
10685       call flush(iout)
10686 #endif
10687 !el#undef DEBUG
10688       do i=-1,nres
10689         do j=1,3
10690           gradbufc_sum(j,i)=gradbufc(j,i)
10691           gradbufc(j,i)=0.0d0
10692         enddo
10693       enddo
10694       do j=1,3
10695         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10696       enddo
10697       do i=nres-2,-1,-1
10698         do j=1,3
10699           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10700         enddo
10701       enddo
10702 !      do i=nnt,nres-1
10703 !        do k=1,3
10704 !          gradbufc(k,i)=0.0d0
10705 !        enddo
10706 !        do j=i+1,nres
10707 !          do k=1,3
10708 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10709 !          enddo
10710 !        enddo
10711 !      enddo
10712 !el#define DEBUG
10713 #ifdef DEBUG
10714       write (iout,*) "gradbufc after summing"
10715       do i=1,nres
10716         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10717       enddo
10718       call flush(iout)
10719 #endif
10720 !el#undef DEBUG
10721 #ifdef MPI
10722       endif
10723 #endif
10724       do k=1,3
10725         gradbufc(k,nres)=0.0d0
10726       enddo
10727 !el----------------
10728 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10729 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10730 !el-----------------
10731       do i=-1,nct
10732         do j=1,3
10733 #ifdef SPLITELE
10734           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10735                       wel_loc*gel_loc(j,i)+ &
10736                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10737                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10738                       wel_loc*gel_loc_long(j,i)+ &
10739                       wcorr*gradcorr_long(j,i)+ &
10740                       wcorr5*gradcorr5_long(j,i)+ &
10741                       wcorr6*gradcorr6_long(j,i)+ &
10742                       wturn6*gcorr6_turn_long(j,i))+ &
10743                       wbond*gradb(j,i)+ &
10744                       wcorr*gradcorr(j,i)+ &
10745                       wturn3*gcorr3_turn(j,i)+ &
10746                       wturn4*gcorr4_turn(j,i)+ &
10747                       wcorr5*gradcorr5(j,i)+ &
10748                       wcorr6*gradcorr6(j,i)+ &
10749                       wturn6*gcorr6_turn(j,i)+ &
10750                       wsccor*gsccorc(j,i) &
10751                      +wscloc*gscloc(j,i)  &
10752                      +wliptran*gliptranc(j,i) &
10753                      +gradafm(j,i) &
10754                      +welec*gshieldc(j,i) &
10755                      +welec*gshieldc_loc(j,i) &
10756                      +wcorr*gshieldc_ec(j,i) &
10757                      +wcorr*gshieldc_loc_ec(j,i) &
10758                      +wturn3*gshieldc_t3(j,i) &
10759                      +wturn3*gshieldc_loc_t3(j,i) &
10760                      +wturn4*gshieldc_t4(j,i) &
10761                      +wturn4*gshieldc_loc_t4(j,i) &
10762                      +wel_loc*gshieldc_ll(j,i) &
10763                      +wel_loc*gshieldc_loc_ll(j,i) &
10764                      +wtube*gg_tube(j,i) &
10765                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10766                      +wvdwpsb*gvdwpsb1(j,i))&
10767                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10768
10769 !                 if ((i.le.2).and.(i.ge.1))
10770 !                       print *,gradc(j,i,icg),&
10771 !                      gradbufc(j,i),welec*gelc(j,i), &
10772 !                      wel_loc*gel_loc(j,i), &
10773 !                      wscp*gvdwc_scpp(j,i), &
10774 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10775 !                      wel_loc*gel_loc_long(j,i), &
10776 !                      wcorr*gradcorr_long(j,i), &
10777 !                      wcorr5*gradcorr5_long(j,i), &
10778 !                      wcorr6*gradcorr6_long(j,i), &
10779 !                      wturn6*gcorr6_turn_long(j,i), &
10780 !                      wbond*gradb(j,i), &
10781 !                      wcorr*gradcorr(j,i), &
10782 !                      wturn3*gcorr3_turn(j,i), &
10783 !                      wturn4*gcorr4_turn(j,i), &
10784 !                      wcorr5*gradcorr5(j,i), &
10785 !                      wcorr6*gradcorr6(j,i), &
10786 !                      wturn6*gcorr6_turn(j,i), &
10787 !                      wsccor*gsccorc(j,i) &
10788 !                     ,wscloc*gscloc(j,i)  &
10789 !                     ,wliptran*gliptranc(j,i) &
10790 !                    ,gradafm(j,i) &
10791 !                     ,welec*gshieldc(j,i) &
10792 !                     ,welec*gshieldc_loc(j,i) &
10793 !                     ,wcorr*gshieldc_ec(j,i) &
10794 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10795 !                     ,wturn3*gshieldc_t3(j,i) &
10796 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10797 !                     ,wturn4*gshieldc_t4(j,i) &
10798 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10799 !                     ,wel_loc*gshieldc_ll(j,i) &
10800 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10801 !                     ,wtube*gg_tube(j,i) &
10802 !                     ,wbond_nucl*gradb_nucl(j,i) &
10803 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10804 !                     wvdwpsb*gvdwpsb1(j,i)&
10805 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10806 !
10807
10808 #else
10809           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10810                       wel_loc*gel_loc(j,i)+ &
10811                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10812                       welec*gelc_long(j,i)+ &
10813                       wel_loc*gel_loc_long(j,i)+ &
10814 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10815                       wcorr5*gradcorr5_long(j,i)+ &
10816                       wcorr6*gradcorr6_long(j,i)+ &
10817                       wturn6*gcorr6_turn_long(j,i))+ &
10818                       wbond*gradb(j,i)+ &
10819                       wcorr*gradcorr(j,i)+ &
10820                       wturn3*gcorr3_turn(j,i)+ &
10821                       wturn4*gcorr4_turn(j,i)+ &
10822                       wcorr5*gradcorr5(j,i)+ &
10823                       wcorr6*gradcorr6(j,i)+ &
10824                       wturn6*gcorr6_turn(j,i)+ &
10825                       wsccor*gsccorc(j,i) &
10826                      +wscloc*gscloc(j,i) &
10827                      +gradafm(j,i) &
10828                      +wliptran*gliptranc(j,i) &
10829                      +welec*gshieldc(j,i) &
10830                      +welec*gshieldc_loc(j,) &
10831                      +wcorr*gshieldc_ec(j,i) &
10832                      +wcorr*gshieldc_loc_ec(j,i) &
10833                      +wturn3*gshieldc_t3(j,i) &
10834                      +wturn3*gshieldc_loc_t3(j,i) &
10835                      +wturn4*gshieldc_t4(j,i) &
10836                      +wturn4*gshieldc_loc_t4(j,i) &
10837                      +wel_loc*gshieldc_ll(j,i) &
10838                      +wel_loc*gshieldc_loc_ll(j,i) &
10839                      +wtube*gg_tube(j,i) &
10840                      +wbond_nucl*gradb_nucl(j,i) &
10841                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10842                      +wvdwpsb*gvdwpsb1(j,i))&
10843                      +wsbloc*gsbloc(j,i)
10844
10845
10846
10847
10848 #endif
10849           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10850                         wbond*gradbx(j,i)+ &
10851                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10852                         wsccor*gsccorx(j,i) &
10853                        +wscloc*gsclocx(j,i) &
10854                        +wliptran*gliptranx(j,i) &
10855                        +welec*gshieldx(j,i)     &
10856                        +wcorr*gshieldx_ec(j,i)  &
10857                        +wturn3*gshieldx_t3(j,i) &
10858                        +wturn4*gshieldx_t4(j,i) &
10859                        +wel_loc*gshieldx_ll(j,i)&
10860                        +wtube*gg_tube_sc(j,i)   &
10861                        +wbond_nucl*gradbx_nucl(j,i) &
10862                        +wvdwsb*gvdwsbx(j,i) &
10863                        +welsb*gelsbx(j,i) &
10864                        +wcorr_nucl*gradxorr_nucl(j,i)&
10865                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10866                        +wsbloc*gsblocx(j,i) &
10867                        +wcatprot* gradpepcatx(j,i)&
10868                        +wscbase*gvdwx_scbase(j,i) &
10869                        +wpepbase*gvdwx_pepbase(j,i)&
10870                        +wscpho*gvdwx_scpho(j,i)
10871 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
10872
10873         enddo
10874       enddo
10875 #ifdef DEBUG
10876       write (iout,*) "gloc before adding corr"
10877       do i=1,4*nres
10878         write (iout,*) i,gloc(i,icg)
10879       enddo
10880 #endif
10881       do i=1,nres-3
10882         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10883          +wcorr5*g_corr5_loc(i) &
10884          +wcorr6*g_corr6_loc(i) &
10885          +wturn4*gel_loc_turn4(i) &
10886          +wturn3*gel_loc_turn3(i) &
10887          +wturn6*gel_loc_turn6(i) &
10888          +wel_loc*gel_loc_loc(i)
10889       enddo
10890 #ifdef DEBUG
10891       write (iout,*) "gloc after adding corr"
10892       do i=1,4*nres
10893         write (iout,*) i,gloc(i,icg)
10894       enddo
10895 #endif
10896 #ifdef MPI
10897       if (nfgtasks.gt.1) then
10898         do j=1,3
10899           do i=0,nres
10900             gradbufc(j,i)=gradc(j,i,icg)
10901             gradbufx(j,i)=gradx(j,i,icg)
10902           enddo
10903         enddo
10904         do i=1,4*nres
10905           glocbuf(i)=gloc(i,icg)
10906         enddo
10907 !#define DEBUG
10908 #ifdef DEBUG
10909       write (iout,*) "gloc_sc before reduce"
10910       do i=1,nres
10911        do j=1,1
10912         write (iout,*) i,j,gloc_sc(j,i,icg)
10913        enddo
10914       enddo
10915 #endif
10916 !#undef DEBUG
10917         do i=1,nres
10918          do j=1,3
10919           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10920          enddo
10921         enddo
10922         time00=MPI_Wtime()
10923         call MPI_Barrier(FG_COMM,IERR)
10924         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10925         time00=MPI_Wtime()
10926         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10927           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10928         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10929           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10930         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10931           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10932         time_reduce=time_reduce+MPI_Wtime()-time00
10933         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10934           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10935         time_reduce=time_reduce+MPI_Wtime()-time00
10936 !#define DEBUG
10937 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10938 #ifdef DEBUG
10939       write (iout,*) "gloc_sc after reduce"
10940       do i=1,nres
10941        do j=1,1
10942         write (iout,*) i,j,gloc_sc(j,i,icg)
10943        enddo
10944       enddo
10945 #endif
10946 !#undef DEBUG
10947 #ifdef DEBUG
10948       write (iout,*) "gloc after reduce"
10949       do i=1,4*nres
10950         write (iout,*) i,gloc(i,icg)
10951       enddo
10952 #endif
10953       endif
10954 #endif
10955       if (gnorm_check) then
10956 !
10957 ! Compute the maximum elements of the gradient
10958 !
10959       gvdwc_max=0.0d0
10960       gvdwc_scp_max=0.0d0
10961       gelc_max=0.0d0
10962       gvdwpp_max=0.0d0
10963       gradb_max=0.0d0
10964       ghpbc_max=0.0d0
10965       gradcorr_max=0.0d0
10966       gel_loc_max=0.0d0
10967       gcorr3_turn_max=0.0d0
10968       gcorr4_turn_max=0.0d0
10969       gradcorr5_max=0.0d0
10970       gradcorr6_max=0.0d0
10971       gcorr6_turn_max=0.0d0
10972       gsccorc_max=0.0d0
10973       gscloc_max=0.0d0
10974       gvdwx_max=0.0d0
10975       gradx_scp_max=0.0d0
10976       ghpbx_max=0.0d0
10977       gradxorr_max=0.0d0
10978       gsccorx_max=0.0d0
10979       gsclocx_max=0.0d0
10980       do i=1,nct
10981         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10982         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10983         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10984         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10985          gvdwc_scp_max=gvdwc_scp_norm
10986         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10987         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10988         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10989         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10990         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10991         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10992         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10993         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10994         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10995         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10996         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10997         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10998         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10999           gcorr3_turn(1,i)))
11000         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11001           gcorr3_turn_max=gcorr3_turn_norm
11002         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11003           gcorr4_turn(1,i)))
11004         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11005           gcorr4_turn_max=gcorr4_turn_norm
11006         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11007         if (gradcorr5_norm.gt.gradcorr5_max) &
11008           gradcorr5_max=gradcorr5_norm
11009         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11010         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11011         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11012           gcorr6_turn(1,i)))
11013         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11014           gcorr6_turn_max=gcorr6_turn_norm
11015         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11016         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11017         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11018         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11019         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11020         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11021         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11022         if (gradx_scp_norm.gt.gradx_scp_max) &
11023           gradx_scp_max=gradx_scp_norm
11024         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11025         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11026         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11027         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11028         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11029         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11030         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11031         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11032       enddo
11033       if (gradout) then
11034 #ifdef AIX
11035         open(istat,file=statname,position="append")
11036 #else
11037         open(istat,file=statname,access="append")
11038 #endif
11039         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11040            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11041            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11042            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11043            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11044            gsccorx_max,gsclocx_max
11045         close(istat)
11046         if (gvdwc_max.gt.1.0d4) then
11047           write (iout,*) "gvdwc gvdwx gradb gradbx"
11048           do i=nnt,nct
11049             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11050               gradb(j,i),gradbx(j,i),j=1,3)
11051           enddo
11052           call pdbout(0.0d0,'cipiszcze',iout)
11053           call flush(iout)
11054         endif
11055       endif
11056       endif
11057 !el#define DEBUG
11058 #ifdef DEBUG
11059       write (iout,*) "gradc gradx gloc"
11060       do i=1,nres
11061         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11062          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11063       enddo
11064 #endif
11065 !el#undef DEBUG
11066 #ifdef TIMING
11067       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11068 #endif
11069       return
11070       end subroutine sum_gradient
11071 !-----------------------------------------------------------------------------
11072       subroutine sc_grad
11073 !      implicit real*8 (a-h,o-z)
11074       use calc_data
11075 !      include 'DIMENSIONS'
11076 !      include 'COMMON.CHAIN'
11077 !      include 'COMMON.DERIV'
11078 !      include 'COMMON.CALC'
11079 !      include 'COMMON.IOUNITS'
11080       real(kind=8), dimension(3) :: dcosom1,dcosom2
11081 !      print *,"wchodze"
11082       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11083           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11084       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11085           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11086
11087       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11088            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11089            +dCAVdOM12+ dGCLdOM12
11090 ! diagnostics only
11091 !      eom1=0.0d0
11092 !      eom2=0.0d0
11093 !      eom12=evdwij*eps1_om12
11094 ! end diagnostics
11095 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11096 !       " sigder",sigder
11097 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11098 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11099 !C      print *,sss_ele_cut,'in sc_grad'
11100       do k=1,3
11101         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11102         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11103       enddo
11104       do k=1,3
11105         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11106 !C      print *,'gg',k,gg(k)
11107        enddo
11108 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11109 !      write (iout,*) "gg",(gg(k),k=1,3)
11110       do k=1,3
11111         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11112                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11113                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11114                   *sss_ele_cut
11115
11116         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11117                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11118                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11119                   *sss_ele_cut
11120
11121 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11122 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11123 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11124 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11125       enddo
11126 !
11127 ! Calculate the components of the gradient in DC and X
11128 !
11129 !grad      do k=i,j-1
11130 !grad        do l=1,3
11131 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11132 !grad        enddo
11133 !grad      enddo
11134       do l=1,3
11135         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11136         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11137       enddo
11138       return
11139       end subroutine sc_grad
11140 #ifdef CRYST_THETA
11141 !-----------------------------------------------------------------------------
11142       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11143
11144       use comm_calcthet
11145 !      implicit real*8 (a-h,o-z)
11146 !      include 'DIMENSIONS'
11147 !      include 'COMMON.LOCAL'
11148 !      include 'COMMON.IOUNITS'
11149 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11150 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11151 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11152       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11153       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11154 !el      integer :: it
11155 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11156 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11157 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11158 !el local variables
11159
11160       delthec=thetai-thet_pred_mean
11161       delthe0=thetai-theta0i
11162 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11163       t3 = thetai-thet_pred_mean
11164       t6 = t3**2
11165       t9 = term1
11166       t12 = t3*sigcsq
11167       t14 = t12+t6*sigsqtc
11168       t16 = 1.0d0
11169       t21 = thetai-theta0i
11170       t23 = t21**2
11171       t26 = term2
11172       t27 = t21*t26
11173       t32 = termexp
11174       t40 = t32**2
11175       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11176        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11177        *(-t12*t9-ak*sig0inv*t27)
11178       return
11179       end subroutine mixder
11180 #endif
11181 !-----------------------------------------------------------------------------
11182 ! cartder.F
11183 !-----------------------------------------------------------------------------
11184       subroutine cartder
11185 !-----------------------------------------------------------------------------
11186 ! This subroutine calculates the derivatives of the consecutive virtual
11187 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11188 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11189 ! in the angles alpha and omega, describing the location of a side chain
11190 ! in its local coordinate system.
11191 !
11192 ! The derivatives are stored in the following arrays:
11193 !
11194 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11195 ! The structure is as follows:
11196 !
11197 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11198 ! 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)
11199 !         . . . . . . . . . . . .  . . . . . .
11200 ! 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)
11201 !                          .
11202 !                          .
11203 !                          .
11204 ! 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)
11205 !
11206 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11207 ! The structure is same as above.
11208 !
11209 ! DCDS - the derivatives of the side chain vectors in the local spherical
11210 ! andgles alph and omega:
11211 !
11212 ! 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)
11213 ! 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)
11214 !                          .
11215 !                          .
11216 !                          .
11217 ! 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)
11218 !
11219 ! Version of March '95, based on an early version of November '91.
11220 !
11221 !**********************************************************************
11222 !      implicit real*8 (a-h,o-z)
11223 !      include 'DIMENSIONS'
11224 !      include 'COMMON.VAR'
11225 !      include 'COMMON.CHAIN'
11226 !      include 'COMMON.DERIV'
11227 !      include 'COMMON.GEO'
11228 !      include 'COMMON.LOCAL'
11229 !      include 'COMMON.INTERACT'
11230       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11231       real(kind=8),dimension(3,3) :: dp,temp
11232 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11233       real(kind=8),dimension(3) :: xx,xx1
11234 !el local variables
11235       integer :: i,k,l,j,m,ind,ind1,jjj
11236       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11237                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11238                  sint2,xp,yp,xxp,yyp,zzp,dj
11239
11240 !      common /przechowalnia/ fromto
11241       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11242 ! get the position of the jth ijth fragment of the chain coordinate system
11243 ! in the fromto array.
11244 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11245 !
11246 !      maxdim=(nres-1)*(nres-2)/2
11247 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11248 ! calculate the derivatives of transformation matrix elements in theta
11249 !
11250
11251 !el      call flush(iout) !el
11252       do i=1,nres-2
11253         rdt(1,1,i)=-rt(1,2,i)
11254         rdt(1,2,i)= rt(1,1,i)
11255         rdt(1,3,i)= 0.0d0
11256         rdt(2,1,i)=-rt(2,2,i)
11257         rdt(2,2,i)= rt(2,1,i)
11258         rdt(2,3,i)= 0.0d0
11259         rdt(3,1,i)=-rt(3,2,i)
11260         rdt(3,2,i)= rt(3,1,i)
11261         rdt(3,3,i)= 0.0d0
11262       enddo
11263 !
11264 ! derivatives in phi
11265 !
11266       do i=2,nres-2
11267         drt(1,1,i)= 0.0d0
11268         drt(1,2,i)= 0.0d0
11269         drt(1,3,i)= 0.0d0
11270         drt(2,1,i)= rt(3,1,i)
11271         drt(2,2,i)= rt(3,2,i)
11272         drt(2,3,i)= rt(3,3,i)
11273         drt(3,1,i)=-rt(2,1,i)
11274         drt(3,2,i)=-rt(2,2,i)
11275         drt(3,3,i)=-rt(2,3,i)
11276       enddo
11277 !
11278 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11279 !
11280       do i=2,nres-2
11281         ind=indmat(i,i+1)
11282         do k=1,3
11283           do l=1,3
11284             temp(k,l)=rt(k,l,i)
11285           enddo
11286         enddo
11287         do k=1,3
11288           do l=1,3
11289             fromto(k,l,ind)=temp(k,l)
11290           enddo
11291         enddo
11292         do j=i+1,nres-2
11293           ind=indmat(i,j+1)
11294           do k=1,3
11295             do l=1,3
11296               dpkl=0.0d0
11297               do m=1,3
11298                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11299               enddo
11300               dp(k,l)=dpkl
11301               fromto(k,l,ind)=dpkl
11302             enddo
11303           enddo
11304           do k=1,3
11305             do l=1,3
11306               temp(k,l)=dp(k,l)
11307             enddo
11308           enddo
11309         enddo
11310       enddo
11311 !
11312 ! Calculate derivatives.
11313 !
11314       ind1=0
11315       do i=1,nres-2
11316       ind1=ind1+1
11317 !
11318 ! Derivatives of DC(i+1) in theta(i+2)
11319 !
11320         do j=1,3
11321           do k=1,2
11322             dpjk=0.0D0
11323             do l=1,3
11324               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11325             enddo
11326             dp(j,k)=dpjk
11327             prordt(j,k,i)=dp(j,k)
11328           enddo
11329           dp(j,3)=0.0D0
11330           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11331         enddo
11332 !
11333 ! Derivatives of SC(i+1) in theta(i+2)
11334 !
11335         xx1(1)=-0.5D0*xloc(2,i+1)
11336         xx1(2)= 0.5D0*xloc(1,i+1)
11337         do j=1,3
11338           xj=0.0D0
11339           do k=1,2
11340             xj=xj+r(j,k,i)*xx1(k)
11341           enddo
11342           xx(j)=xj
11343         enddo
11344         do j=1,3
11345           rj=0.0D0
11346           do k=1,3
11347             rj=rj+prod(j,k,i)*xx(k)
11348           enddo
11349           dxdv(j,ind1)=rj
11350         enddo
11351 !
11352 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11353 ! than the other off-diagonal derivatives.
11354 !
11355         do j=1,3
11356           dxoiij=0.0D0
11357           do k=1,3
11358             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11359           enddo
11360           dxdv(j,ind1+1)=dxoiij
11361         enddo
11362 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11363 !
11364 ! Derivatives of DC(i+1) in phi(i+2)
11365 !
11366         do j=1,3
11367           do k=1,3
11368             dpjk=0.0
11369             do l=2,3
11370               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11371             enddo
11372             dp(j,k)=dpjk
11373             prodrt(j,k,i)=dp(j,k)
11374           enddo
11375           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11376         enddo
11377 !
11378 ! Derivatives of SC(i+1) in phi(i+2)
11379 !
11380         xx(1)= 0.0D0
11381         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11382         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11383         do j=1,3
11384           rj=0.0D0
11385           do k=2,3
11386             rj=rj+prod(j,k,i)*xx(k)
11387           enddo
11388           dxdv(j+3,ind1)=-rj
11389         enddo
11390 !
11391 ! Derivatives of SC(i+1) in phi(i+3).
11392 !
11393         do j=1,3
11394           dxoiij=0.0D0
11395           do k=1,3
11396             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11397           enddo
11398           dxdv(j+3,ind1+1)=dxoiij
11399         enddo
11400 !
11401 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11402 ! theta(nres) and phi(i+3) thru phi(nres).
11403 !
11404         do j=i+1,nres-2
11405         ind1=ind1+1
11406         ind=indmat(i+1,j+1)
11407 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11408           do k=1,3
11409             do l=1,3
11410               tempkl=0.0D0
11411               do m=1,2
11412                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11413               enddo
11414               temp(k,l)=tempkl
11415             enddo
11416           enddo
11417 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11418 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11419 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11420 ! Derivatives of virtual-bond vectors in theta
11421           do k=1,3
11422             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11423           enddo
11424 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11425 ! Derivatives of SC vectors in theta
11426           do k=1,3
11427             dxoijk=0.0D0
11428             do l=1,3
11429               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11430             enddo
11431             dxdv(k,ind1+1)=dxoijk
11432           enddo
11433 !
11434 !--- Calculate the derivatives in phi
11435 !
11436           do k=1,3
11437             do l=1,3
11438               tempkl=0.0D0
11439               do m=1,3
11440                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11441               enddo
11442               temp(k,l)=tempkl
11443             enddo
11444           enddo
11445           do k=1,3
11446             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11447         enddo
11448           do k=1,3
11449             dxoijk=0.0D0
11450             do l=1,3
11451               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11452             enddo
11453             dxdv(k+3,ind1+1)=dxoijk
11454           enddo
11455         enddo
11456       enddo
11457 !
11458 ! Derivatives in alpha and omega:
11459 !
11460       do i=2,nres-1
11461 !       dsci=dsc(itype(i,1))
11462         dsci=vbld(i+nres)
11463 #ifdef OSF
11464         alphi=alph(i)
11465         omegi=omeg(i)
11466         if(alphi.ne.alphi) alphi=100.0
11467         if(omegi.ne.omegi) omegi=-100.0
11468 #else
11469       alphi=alph(i)
11470       omegi=omeg(i)
11471 #endif
11472 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11473       cosalphi=dcos(alphi)
11474       sinalphi=dsin(alphi)
11475       cosomegi=dcos(omegi)
11476       sinomegi=dsin(omegi)
11477       temp(1,1)=-dsci*sinalphi
11478       temp(2,1)= dsci*cosalphi*cosomegi
11479       temp(3,1)=-dsci*cosalphi*sinomegi
11480       temp(1,2)=0.0D0
11481       temp(2,2)=-dsci*sinalphi*sinomegi
11482       temp(3,2)=-dsci*sinalphi*cosomegi
11483       theta2=pi-0.5D0*theta(i+1)
11484       cost2=dcos(theta2)
11485       sint2=dsin(theta2)
11486       jjj=0
11487 !d      print *,((temp(l,k),l=1,3),k=1,2)
11488         do j=1,2
11489         xp=temp(1,j)
11490         yp=temp(2,j)
11491         xxp= xp*cost2+yp*sint2
11492         yyp=-xp*sint2+yp*cost2
11493         zzp=temp(3,j)
11494         xx(1)=xxp
11495         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11496         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11497         do k=1,3
11498           dj=0.0D0
11499           do l=1,3
11500             dj=dj+prod(k,l,i-1)*xx(l)
11501             enddo
11502           dxds(jjj+k,i)=dj
11503           enddo
11504         jjj=jjj+3
11505       enddo
11506       enddo
11507       return
11508       end subroutine cartder
11509 !-----------------------------------------------------------------------------
11510 ! checkder_p.F
11511 !-----------------------------------------------------------------------------
11512       subroutine check_cartgrad
11513 ! Check the gradient of Cartesian coordinates in internal coordinates.
11514 !      implicit real*8 (a-h,o-z)
11515 !      include 'DIMENSIONS'
11516 !      include 'COMMON.IOUNITS'
11517 !      include 'COMMON.VAR'
11518 !      include 'COMMON.CHAIN'
11519 !      include 'COMMON.GEO'
11520 !      include 'COMMON.LOCAL'
11521 !      include 'COMMON.DERIV'
11522       real(kind=8),dimension(6,nres) :: temp
11523       real(kind=8),dimension(3) :: xx,gg
11524       integer :: i,k,j,ii
11525       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11526 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11527 !
11528 ! Check the gradient of the virtual-bond and SC vectors in the internal
11529 ! coordinates.
11530 !
11531       aincr=1.0d-6
11532       aincr2=5.0d-7
11533       call cartder
11534       write (iout,'(a)') '**************** dx/dalpha'
11535       write (iout,'(a)')
11536       do i=2,nres-1
11537       alphi=alph(i)
11538       alph(i)=alph(i)+aincr
11539       do k=1,3
11540         temp(k,i)=dc(k,nres+i)
11541         enddo
11542       call chainbuild
11543       do k=1,3
11544         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11545         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11546         enddo
11547         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11548         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11549         write (iout,'(a)')
11550       alph(i)=alphi
11551       call chainbuild
11552       enddo
11553       write (iout,'(a)')
11554       write (iout,'(a)') '**************** dx/domega'
11555       write (iout,'(a)')
11556       do i=2,nres-1
11557       omegi=omeg(i)
11558       omeg(i)=omeg(i)+aincr
11559       do k=1,3
11560         temp(k,i)=dc(k,nres+i)
11561         enddo
11562       call chainbuild
11563       do k=1,3
11564           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11565           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11566                 (aincr*dabs(dxds(k+3,i))+aincr))
11567         enddo
11568         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11569             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11570         write (iout,'(a)')
11571       omeg(i)=omegi
11572       call chainbuild
11573       enddo
11574       write (iout,'(a)')
11575       write (iout,'(a)') '**************** dx/dtheta'
11576       write (iout,'(a)')
11577       do i=3,nres
11578       theti=theta(i)
11579         theta(i)=theta(i)+aincr
11580         do j=i-1,nres-1
11581           do k=1,3
11582             temp(k,j)=dc(k,nres+j)
11583           enddo
11584         enddo
11585         call chainbuild
11586         do j=i-1,nres-1
11587         ii = indmat(i-2,j)
11588 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11589         do k=1,3
11590           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11591           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11592                   (aincr*dabs(dxdv(k,ii))+aincr))
11593           enddo
11594           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11595               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11596           write(iout,'(a)')
11597         enddo
11598         write (iout,'(a)')
11599         theta(i)=theti
11600         call chainbuild
11601       enddo
11602       write (iout,'(a)') '***************** dx/dphi'
11603       write (iout,'(a)')
11604       do i=4,nres
11605         phi(i)=phi(i)+aincr
11606         do j=i-1,nres-1
11607           do k=1,3
11608             temp(k,j)=dc(k,nres+j)
11609           enddo
11610         enddo
11611         call chainbuild
11612         do j=i-1,nres-1
11613         ii = indmat(i-2,j)
11614 !         print *,'ii=',ii
11615         do k=1,3
11616           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11617             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11618                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11619           enddo
11620           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11621               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11622           write(iout,'(a)')
11623         enddo
11624         phi(i)=phi(i)-aincr
11625         call chainbuild
11626       enddo
11627       write (iout,'(a)') '****************** ddc/dtheta'
11628       do i=1,nres-2
11629         thet=theta(i+2)
11630         theta(i+2)=thet+aincr
11631         do j=i,nres
11632           do k=1,3
11633             temp(k,j)=dc(k,j)
11634           enddo
11635         enddo
11636         call chainbuild
11637         do j=i+1,nres-1
11638         ii = indmat(i,j)
11639 !         print *,'ii=',ii
11640         do k=1,3
11641           gg(k)=(dc(k,j)-temp(k,j))/aincr
11642           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11643                  (aincr*dabs(dcdv(k,ii))+aincr))
11644           enddo
11645           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11646                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11647         write (iout,'(a)')
11648         enddo
11649         do j=1,nres
11650           do k=1,3
11651             dc(k,j)=temp(k,j)
11652           enddo
11653         enddo
11654         theta(i+2)=thet
11655       enddo
11656       write (iout,'(a)') '******************* ddc/dphi'
11657       do i=1,nres-3
11658         phii=phi(i+3)
11659         phi(i+3)=phii+aincr
11660         do j=1,nres
11661           do k=1,3
11662             temp(k,j)=dc(k,j)
11663           enddo
11664         enddo
11665         call chainbuild
11666         do j=i+2,nres-1
11667         ii = indmat(i+1,j)
11668 !         print *,'ii=',ii
11669         do k=1,3
11670           gg(k)=(dc(k,j)-temp(k,j))/aincr
11671             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11672                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11673           enddo
11674           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11675                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11676         write (iout,'(a)')
11677         enddo
11678         do j=1,nres
11679           do k=1,3
11680             dc(k,j)=temp(k,j)
11681           enddo
11682         enddo
11683         phi(i+3)=phii
11684       enddo
11685       return
11686       end subroutine check_cartgrad
11687 !-----------------------------------------------------------------------------
11688       subroutine check_ecart
11689 ! Check the gradient of the energy in Cartesian coordinates.
11690 !     implicit real*8 (a-h,o-z)
11691 !     include 'DIMENSIONS'
11692 !     include 'COMMON.CHAIN'
11693 !     include 'COMMON.DERIV'
11694 !     include 'COMMON.IOUNITS'
11695 !     include 'COMMON.VAR'
11696 !     include 'COMMON.CONTACTS'
11697       use comm_srutu
11698 !el      integer :: icall
11699 !el      common /srutu/ icall
11700       real(kind=8),dimension(6) :: ggg
11701       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11702       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11703       real(kind=8),dimension(6,nres) :: grad_s
11704       real(kind=8),dimension(0:n_ene) :: energia,energia1
11705       integer :: uiparm(1)
11706       real(kind=8) :: urparm(1)
11707 !EL      external fdum
11708       integer :: nf,i,j,k
11709       real(kind=8) :: aincr,etot,etot1
11710       icg=1
11711       nf=0
11712       nfl=0
11713       call zerograd
11714       aincr=1.0D-5
11715       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11716       nf=0
11717       icall=0
11718       call geom_to_var(nvar,x)
11719       call etotal(energia)
11720       etot=energia(0)
11721 !el      call enerprint(energia)
11722       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11723       icall =1
11724       do i=1,nres
11725         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11726       enddo
11727       do i=1,nres
11728       do j=1,3
11729         grad_s(j,i)=gradc(j,i,icg)
11730         grad_s(j+3,i)=gradx(j,i,icg)
11731         enddo
11732       enddo
11733       call flush(iout)
11734       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11735       do i=1,nres
11736         do j=1,3
11737         xx(j)=c(j,i+nres)
11738         ddc(j)=dc(j,i)
11739         ddx(j)=dc(j,i+nres)
11740         enddo
11741       do j=1,3
11742         dc(j,i)=dc(j,i)+aincr
11743         do k=i+1,nres
11744           c(j,k)=c(j,k)+aincr
11745           c(j,k+nres)=c(j,k+nres)+aincr
11746           enddo
11747           call etotal(energia1)
11748           etot1=energia1(0)
11749         ggg(j)=(etot1-etot)/aincr
11750         dc(j,i)=ddc(j)
11751         do k=i+1,nres
11752           c(j,k)=c(j,k)-aincr
11753           c(j,k+nres)=c(j,k+nres)-aincr
11754           enddo
11755         enddo
11756       do j=1,3
11757         c(j,i+nres)=c(j,i+nres)+aincr
11758         dc(j,i+nres)=dc(j,i+nres)+aincr
11759           call etotal(energia1)
11760           etot1=energia1(0)
11761         ggg(j+3)=(etot1-etot)/aincr
11762         c(j,i+nres)=xx(j)
11763         dc(j,i+nres)=ddx(j)
11764         enddo
11765       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11766          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11767       enddo
11768       return
11769       end subroutine check_ecart
11770 #ifdef CARGRAD
11771 !-----------------------------------------------------------------------------
11772       subroutine check_ecartint
11773 ! Check the gradient of the energy in Cartesian coordinates.
11774       use io_base, only: intout
11775 !      implicit real*8 (a-h,o-z)
11776 !      include 'DIMENSIONS'
11777 !      include 'COMMON.CONTROL'
11778 !      include 'COMMON.CHAIN'
11779 !      include 'COMMON.DERIV'
11780 !      include 'COMMON.IOUNITS'
11781 !      include 'COMMON.VAR'
11782 !      include 'COMMON.CONTACTS'
11783 !      include 'COMMON.MD'
11784 !      include 'COMMON.LOCAL'
11785 !      include 'COMMON.SPLITELE'
11786       use comm_srutu
11787 !el      integer :: icall
11788 !el      common /srutu/ icall
11789       real(kind=8),dimension(6) :: ggg,ggg1
11790       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11791       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11792       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11793       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11794       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11795       real(kind=8),dimension(0:n_ene) :: energia,energia1
11796       integer :: uiparm(1)
11797       real(kind=8) :: urparm(1)
11798 !EL      external fdum
11799       integer :: i,j,k,nf
11800       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11801                    etot21,etot22
11802       r_cut=2.0d0
11803       rlambd=0.3d0
11804       icg=1
11805       nf=0
11806       nfl=0
11807       call intout
11808 !      call intcartderiv
11809 !      call checkintcartgrad
11810       call zerograd
11811       aincr=1.0D-4
11812       write(iout,*) 'Calling CHECK_ECARTINT.'
11813       nf=0
11814       icall=0
11815       call geom_to_var(nvar,x)
11816       write (iout,*) "split_ene ",split_ene
11817       call flush(iout)
11818       if (.not.split_ene) then
11819         call etotal(energia)
11820         etot=energia(0)
11821         call cartgrad
11822         icall =1
11823         do i=1,nres
11824           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11825         enddo
11826         do j=1,3
11827           grad_s(j,0)=gcart(j,0)
11828         enddo
11829         do i=1,nres
11830           do j=1,3
11831             grad_s(j,i)=gcart(j,i)
11832             grad_s(j+3,i)=gxcart(j,i)
11833           enddo
11834         enddo
11835       else
11836 !- split gradient check
11837         call zerograd
11838         call etotal_long(energia)
11839 !el        call enerprint(energia)
11840         call cartgrad
11841         icall =1
11842         do i=1,nres
11843           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11844           (gxcart(j,i),j=1,3)
11845         enddo
11846         do j=1,3
11847           grad_s(j,0)=gcart(j,0)
11848         enddo
11849         do i=1,nres
11850           do j=1,3
11851             grad_s(j,i)=gcart(j,i)
11852             grad_s(j+3,i)=gxcart(j,i)
11853           enddo
11854         enddo
11855         call zerograd
11856         call etotal_short(energia)
11857         call enerprint(energia)
11858         call cartgrad
11859         icall =1
11860         do i=1,nres
11861           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11862           (gxcart(j,i),j=1,3)
11863         enddo
11864         do j=1,3
11865           grad_s1(j,0)=gcart(j,0)
11866         enddo
11867         do i=1,nres
11868           do j=1,3
11869             grad_s1(j,i)=gcart(j,i)
11870             grad_s1(j+3,i)=gxcart(j,i)
11871           enddo
11872         enddo
11873       endif
11874       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11875 !      do i=1,nres
11876       do i=nnt,nct
11877         do j=1,3
11878           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11879           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11880         ddc(j)=c(j,i)
11881         ddx(j)=c(j,i+nres)
11882           dcnorm_safe1(j)=dc_norm(j,i-1)
11883           dcnorm_safe2(j)=dc_norm(j,i)
11884           dxnorm_safe(j)=dc_norm(j,i+nres)
11885         enddo
11886       do j=1,3
11887         c(j,i)=ddc(j)+aincr
11888           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11889           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11890           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11891           dc(j,i)=c(j,i+1)-c(j,i)
11892           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11893           call int_from_cart1(.false.)
11894           if (.not.split_ene) then
11895             call etotal(energia1)
11896             etot1=energia1(0)
11897             write (iout,*) "ij",i,j," etot1",etot1
11898           else
11899 !- split gradient
11900             call etotal_long(energia1)
11901             etot11=energia1(0)
11902             call etotal_short(energia1)
11903             etot12=energia1(0)
11904           endif
11905 !- end split gradient
11906 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11907         c(j,i)=ddc(j)-aincr
11908           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11909           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11910           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11911           dc(j,i)=c(j,i+1)-c(j,i)
11912           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11913           call int_from_cart1(.false.)
11914           if (.not.split_ene) then
11915             call etotal(energia1)
11916             etot2=energia1(0)
11917             write (iout,*) "ij",i,j," etot2",etot2
11918           ggg(j)=(etot1-etot2)/(2*aincr)
11919           else
11920 !- split gradient
11921             call etotal_long(energia1)
11922             etot21=energia1(0)
11923           ggg(j)=(etot11-etot21)/(2*aincr)
11924             call etotal_short(energia1)
11925             etot22=energia1(0)
11926           ggg1(j)=(etot12-etot22)/(2*aincr)
11927 !- end split gradient
11928 !            write (iout,*) "etot21",etot21," etot22",etot22
11929           endif
11930 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11931         c(j,i)=ddc(j)
11932           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11933           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11934           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11935           dc(j,i)=c(j,i+1)-c(j,i)
11936           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11937           dc_norm(j,i-1)=dcnorm_safe1(j)
11938           dc_norm(j,i)=dcnorm_safe2(j)
11939           dc_norm(j,i+nres)=dxnorm_safe(j)
11940         enddo
11941       do j=1,3
11942         c(j,i+nres)=ddx(j)+aincr
11943           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11944           call int_from_cart1(.false.)
11945           if (.not.split_ene) then
11946             call etotal(energia1)
11947             etot1=energia1(0)
11948           else
11949 !- split gradient
11950             call etotal_long(energia1)
11951             etot11=energia1(0)
11952             call etotal_short(energia1)
11953             etot12=energia1(0)
11954           endif
11955 !- end split gradient
11956         c(j,i+nres)=ddx(j)-aincr
11957           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11958           call int_from_cart1(.false.)
11959           if (.not.split_ene) then
11960             call etotal(energia1)
11961             etot2=energia1(0)
11962           ggg(j+3)=(etot1-etot2)/(2*aincr)
11963           else
11964 !- split gradient
11965             call etotal_long(energia1)
11966             etot21=energia1(0)
11967           ggg(j+3)=(etot11-etot21)/(2*aincr)
11968             call etotal_short(energia1)
11969             etot22=energia1(0)
11970           ggg1(j+3)=(etot12-etot22)/(2*aincr)
11971 !- end split gradient
11972           endif
11973 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11974         c(j,i+nres)=ddx(j)
11975           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11976           dc_norm(j,i+nres)=dxnorm_safe(j)
11977           call int_from_cart1(.false.)
11978         enddo
11979       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11980          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11981         if (split_ene) then
11982           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11983          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11984          k=1,6)
11985          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11986          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11987          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11988         endif
11989       enddo
11990       return
11991       end subroutine check_ecartint
11992 #else
11993 !-----------------------------------------------------------------------------
11994       subroutine check_ecartint
11995 ! Check the gradient of the energy in Cartesian coordinates.
11996       use io_base, only: intout
11997 !      implicit real*8 (a-h,o-z)
11998 !      include 'DIMENSIONS'
11999 !      include 'COMMON.CONTROL'
12000 !      include 'COMMON.CHAIN'
12001 !      include 'COMMON.DERIV'
12002 !      include 'COMMON.IOUNITS'
12003 !      include 'COMMON.VAR'
12004 !      include 'COMMON.CONTACTS'
12005 !      include 'COMMON.MD'
12006 !      include 'COMMON.LOCAL'
12007 !      include 'COMMON.SPLITELE'
12008       use comm_srutu
12009 !el      integer :: icall
12010 !el      common /srutu/ icall
12011       real(kind=8),dimension(6) :: ggg,ggg1
12012       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12013       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12014       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12015       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12016       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12017       real(kind=8),dimension(0:n_ene) :: energia,energia1
12018       integer :: uiparm(1)
12019       real(kind=8) :: urparm(1)
12020 !EL      external fdum
12021       integer :: i,j,k,nf
12022       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12023                    etot21,etot22
12024       r_cut=2.0d0
12025       rlambd=0.3d0
12026       icg=1
12027       nf=0
12028       nfl=0
12029       call intout
12030 !      call intcartderiv
12031 !      call checkintcartgrad
12032       call zerograd
12033       aincr=2.0D-5
12034       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12035       nf=0
12036       icall=0
12037       call geom_to_var(nvar,x)
12038       if (.not.split_ene) then
12039         call etotal(energia)
12040         etot=energia(0)
12041 !el        call enerprint(energia)
12042         call cartgrad
12043         icall =1
12044         do i=1,nres
12045           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12046         enddo
12047         do j=1,3
12048           grad_s(j,0)=gcart(j,0)
12049         enddo
12050         do i=1,nres
12051           do j=1,3
12052             grad_s(j,i)=gcart(j,i)
12053 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12054             grad_s(j+3,i)=gxcart(j,i)
12055           enddo
12056         enddo
12057       else
12058 !- split gradient check
12059         call zerograd
12060         call etotal_long(energia)
12061 !el        call enerprint(energia)
12062         call cartgrad
12063         icall =1
12064         do i=1,nres
12065           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12066           (gxcart(j,i),j=1,3)
12067         enddo
12068         do j=1,3
12069           grad_s(j,0)=gcart(j,0)
12070         enddo
12071         do i=1,nres
12072           do j=1,3
12073             grad_s(j,i)=gcart(j,i)
12074             grad_s(j+3,i)=gxcart(j,i)
12075           enddo
12076         enddo
12077         call zerograd
12078         call etotal_short(energia)
12079 !el        call enerprint(energia)
12080         call cartgrad
12081         icall =1
12082         do i=1,nres
12083           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12084           (gxcart(j,i),j=1,3)
12085         enddo
12086         do j=1,3
12087           grad_s1(j,0)=gcart(j,0)
12088         enddo
12089         do i=1,nres
12090           do j=1,3
12091             grad_s1(j,i)=gcart(j,i)
12092             grad_s1(j+3,i)=gxcart(j,i)
12093           enddo
12094         enddo
12095       endif
12096       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12097       do i=0,nres
12098         do j=1,3
12099         xx(j)=c(j,i+nres)
12100         ddc(j)=dc(j,i)
12101         ddx(j)=dc(j,i+nres)
12102           do k=1,3
12103             dcnorm_safe(k)=dc_norm(k,i)
12104             dxnorm_safe(k)=dc_norm(k,i+nres)
12105           enddo
12106         enddo
12107       do j=1,3
12108         dc(j,i)=ddc(j)+aincr
12109           call chainbuild_cart
12110 #ifdef MPI
12111 ! Broadcast the order to compute internal coordinates to the slaves.
12112 !          if (nfgtasks.gt.1)
12113 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12114 #endif
12115 !          call int_from_cart1(.false.)
12116           if (.not.split_ene) then
12117             call etotal(energia1)
12118             etot1=energia1(0)
12119 !            call enerprint(energia1)
12120           else
12121 !- split gradient
12122             call etotal_long(energia1)
12123             etot11=energia1(0)
12124             call etotal_short(energia1)
12125             etot12=energia1(0)
12126 !            write (iout,*) "etot11",etot11," etot12",etot12
12127           endif
12128 !- end split gradient
12129 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12130         dc(j,i)=ddc(j)-aincr
12131           call chainbuild_cart
12132 !          call int_from_cart1(.false.)
12133           if (.not.split_ene) then
12134             call etotal(energia1)
12135             etot2=energia1(0)
12136           ggg(j)=(etot1-etot2)/(2*aincr)
12137           else
12138 !- split gradient
12139             call etotal_long(energia1)
12140             etot21=energia1(0)
12141           ggg(j)=(etot11-etot21)/(2*aincr)
12142             call etotal_short(energia1)
12143             etot22=energia1(0)
12144           ggg1(j)=(etot12-etot22)/(2*aincr)
12145 !- end split gradient
12146 !            write (iout,*) "etot21",etot21," etot22",etot22
12147           endif
12148 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12149         dc(j,i)=ddc(j)
12150           call chainbuild_cart
12151         enddo
12152       do j=1,3
12153         dc(j,i+nres)=ddx(j)+aincr
12154           call chainbuild_cart
12155 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12156 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12157 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12158 !          write (iout,*) "dxnormnorm",dsqrt(
12159 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12160 !          write (iout,*) "dxnormnormsafe",dsqrt(
12161 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12162 !          write (iout,*)
12163           if (.not.split_ene) then
12164             call etotal(energia1)
12165             etot1=energia1(0)
12166           else
12167 !- split gradient
12168             call etotal_long(energia1)
12169             etot11=energia1(0)
12170             call etotal_short(energia1)
12171             etot12=energia1(0)
12172           endif
12173 !- end split gradient
12174 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12175         dc(j,i+nres)=ddx(j)-aincr
12176           call chainbuild_cart
12177 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12178 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12179 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12180 !          write (iout,*)
12181 !          write (iout,*) "dxnormnorm",dsqrt(
12182 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12183 !          write (iout,*) "dxnormnormsafe",dsqrt(
12184 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12185           if (.not.split_ene) then
12186             call etotal(energia1)
12187             etot2=energia1(0)
12188           ggg(j+3)=(etot1-etot2)/(2*aincr)
12189           else
12190 !- split gradient
12191             call etotal_long(energia1)
12192             etot21=energia1(0)
12193           ggg(j+3)=(etot11-etot21)/(2*aincr)
12194             call etotal_short(energia1)
12195             etot22=energia1(0)
12196           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12197 !- end split gradient
12198           endif
12199 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12200         dc(j,i+nres)=ddx(j)
12201           call chainbuild_cart
12202         enddo
12203       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12204          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12205         if (split_ene) then
12206           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12207          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12208          k=1,6)
12209          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12210          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12211          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12212         endif
12213       enddo
12214       return
12215       end subroutine check_ecartint
12216 #endif
12217 !-----------------------------------------------------------------------------
12218       subroutine check_eint
12219 ! Check the gradient of energy in internal coordinates.
12220 !      implicit real*8 (a-h,o-z)
12221 !      include 'DIMENSIONS'
12222 !      include 'COMMON.CHAIN'
12223 !      include 'COMMON.DERIV'
12224 !      include 'COMMON.IOUNITS'
12225 !      include 'COMMON.VAR'
12226 !      include 'COMMON.GEO'
12227       use comm_srutu
12228 !el      integer :: icall
12229 !el      common /srutu/ icall
12230       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12231       integer :: uiparm(1)
12232       real(kind=8) :: urparm(1)
12233       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12234       character(len=6) :: key
12235 !EL      external fdum
12236       integer :: i,ii,nf
12237       real(kind=8) :: xi,aincr,etot,etot1,etot2
12238       call zerograd
12239       aincr=1.0D-7
12240       print '(a)','Calling CHECK_INT.'
12241       nf=0
12242       nfl=0
12243       icg=1
12244       call geom_to_var(nvar,x)
12245       call var_to_geom(nvar,x)
12246       call chainbuild
12247       icall=1
12248 !      print *,'ICG=',ICG
12249       call etotal(energia)
12250       etot = energia(0)
12251 !el      call enerprint(energia)
12252 !      print *,'ICG=',ICG
12253 #ifdef MPL
12254       if (MyID.ne.BossID) then
12255         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12256         nf=x(nvar+1)
12257         nfl=x(nvar+2)
12258         icg=x(nvar+3)
12259       endif
12260 #endif
12261       nf=1
12262       nfl=3
12263 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12264       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12265 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12266       icall=1
12267       do i=1,nvar
12268         xi=x(i)
12269         x(i)=xi-0.5D0*aincr
12270         call var_to_geom(nvar,x)
12271         call chainbuild
12272         call etotal(energia1)
12273         etot1=energia1(0)
12274         x(i)=xi+0.5D0*aincr
12275         call var_to_geom(nvar,x)
12276         call chainbuild
12277         call etotal(energia2)
12278         etot2=energia2(0)
12279         gg(i)=(etot2-etot1)/aincr
12280         write (iout,*) i,etot1,etot2
12281         x(i)=xi
12282       enddo
12283       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12284           '     RelDiff*100% '
12285       do i=1,nvar
12286         if (i.le.nphi) then
12287           ii=i
12288           key = ' phi'
12289         else if (i.le.nphi+ntheta) then
12290           ii=i-nphi
12291           key=' theta'
12292         else if (i.le.nphi+ntheta+nside) then
12293            ii=i-(nphi+ntheta)
12294            key=' alpha'
12295         else
12296            ii=i-(nphi+ntheta+nside)
12297            key=' omega'
12298         endif
12299         write (iout,'(i3,a,i3,3(1pd16.6))') &
12300        i,key,ii,gg(i),gana(i),&
12301        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12302       enddo
12303       return
12304       end subroutine check_eint
12305 !-----------------------------------------------------------------------------
12306 ! econstr_local.F
12307 !-----------------------------------------------------------------------------
12308       subroutine Econstr_back
12309 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12310 !      implicit real*8 (a-h,o-z)
12311 !      include 'DIMENSIONS'
12312 !      include 'COMMON.CONTROL'
12313 !      include 'COMMON.VAR'
12314 !      include 'COMMON.MD'
12315       use MD_data
12316 !#ifndef LANG0
12317 !      include 'COMMON.LANGEVIN'
12318 !#else
12319 !      include 'COMMON.LANGEVIN.lang0'
12320 !#endif
12321 !      include 'COMMON.CHAIN'
12322 !      include 'COMMON.DERIV'
12323 !      include 'COMMON.GEO'
12324 !      include 'COMMON.LOCAL'
12325 !      include 'COMMON.INTERACT'
12326 !      include 'COMMON.IOUNITS'
12327 !      include 'COMMON.NAMES'
12328 !      include 'COMMON.TIME1'
12329       integer :: i,j,ii,k
12330       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12331
12332       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12333       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12334       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12335
12336       Uconst_back=0.0d0
12337       do i=1,nres
12338         dutheta(i)=0.0d0
12339         dugamma(i)=0.0d0
12340         do j=1,3
12341           duscdiff(j,i)=0.0d0
12342           duscdiffx(j,i)=0.0d0
12343         enddo
12344       enddo
12345       do i=1,nfrag_back
12346         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12347 !
12348 ! Deviations from theta angles
12349 !
12350         utheta_i=0.0d0
12351         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12352           dtheta_i=theta(j)-thetaref(j)
12353           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12354           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12355         enddo
12356         utheta(i)=utheta_i/(ii-1)
12357 !
12358 ! Deviations from gamma angles
12359 !
12360         ugamma_i=0.0d0
12361         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12362           dgamma_i=pinorm(phi(j)-phiref(j))
12363 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12364           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12365           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12366 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12367         enddo
12368         ugamma(i)=ugamma_i/(ii-2)
12369 !
12370 ! Deviations from local SC geometry
12371 !
12372         uscdiff(i)=0.0d0
12373         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12374           dxx=xxtab(j)-xxref(j)
12375           dyy=yytab(j)-yyref(j)
12376           dzz=zztab(j)-zzref(j)
12377           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12378           do k=1,3
12379             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12380              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12381              (ii-1)
12382             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12383              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12384              (ii-1)
12385             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12386            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12387             /(ii-1)
12388           enddo
12389 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12390 !     &      xxref(j),yyref(j),zzref(j)
12391         enddo
12392         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12393 !        write (iout,*) i," uscdiff",uscdiff(i)
12394 !
12395 ! Put together deviations from local geometry
12396 !
12397         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12398           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12399 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12400 !     &   " uconst_back",uconst_back
12401         utheta(i)=dsqrt(utheta(i))
12402         ugamma(i)=dsqrt(ugamma(i))
12403         uscdiff(i)=dsqrt(uscdiff(i))
12404       enddo
12405       return
12406       end subroutine Econstr_back
12407 !-----------------------------------------------------------------------------
12408 ! energy_p_new-sep_barrier.F
12409 !-----------------------------------------------------------------------------
12410       real(kind=8) function sscale(r)
12411 !      include "COMMON.SPLITELE"
12412       real(kind=8) :: r,gamm
12413       if(r.lt.r_cut-rlamb) then
12414         sscale=1.0d0
12415       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12416         gamm=(r-(r_cut-rlamb))/rlamb
12417         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12418       else
12419         sscale=0d0
12420       endif
12421       return
12422       end function sscale
12423       real(kind=8) function sscale_grad(r)
12424 !      include "COMMON.SPLITELE"
12425       real(kind=8) :: r,gamm
12426       if(r.lt.r_cut-rlamb) then
12427         sscale_grad=0.0d0
12428       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12429         gamm=(r-(r_cut-rlamb))/rlamb
12430         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12431       else
12432         sscale_grad=0d0
12433       endif
12434       return
12435       end function sscale_grad
12436
12437 !!!!!!!!!! PBCSCALE
12438       real(kind=8) function sscale_ele(r)
12439 !      include "COMMON.SPLITELE"
12440       real(kind=8) :: r,gamm
12441       if(r.lt.r_cut_ele-rlamb_ele) then
12442         sscale_ele=1.0d0
12443       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12444         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12445         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12446       else
12447         sscale_ele=0d0
12448       endif
12449       return
12450       end function sscale_ele
12451
12452       real(kind=8)  function sscagrad_ele(r)
12453       real(kind=8) :: r,gamm
12454 !      include "COMMON.SPLITELE"
12455       if(r.lt.r_cut_ele-rlamb_ele) then
12456         sscagrad_ele=0.0d0
12457       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12458         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12459         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12460       else
12461         sscagrad_ele=0.0d0
12462       endif
12463       return
12464       end function sscagrad_ele
12465       real(kind=8) function sscalelip(r)
12466       real(kind=8) r,gamm
12467         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12468       return
12469       end function sscalelip
12470 !C-----------------------------------------------------------------------
12471       real(kind=8) function sscagradlip(r)
12472       real(kind=8) r,gamm
12473         sscagradlip=r*(6.0d0*r-6.0d0)
12474       return
12475       end function sscagradlip
12476
12477 !!!!!!!!!!!!!!!
12478 !-----------------------------------------------------------------------------
12479       subroutine elj_long(evdw)
12480 !
12481 ! This subroutine calculates the interaction energy of nonbonded side chains
12482 ! assuming the LJ potential of interaction.
12483 !
12484 !      implicit real*8 (a-h,o-z)
12485 !      include 'DIMENSIONS'
12486 !      include 'COMMON.GEO'
12487 !      include 'COMMON.VAR'
12488 !      include 'COMMON.LOCAL'
12489 !      include 'COMMON.CHAIN'
12490 !      include 'COMMON.DERIV'
12491 !      include 'COMMON.INTERACT'
12492 !      include 'COMMON.TORSION'
12493 !      include 'COMMON.SBRIDGE'
12494 !      include 'COMMON.NAMES'
12495 !      include 'COMMON.IOUNITS'
12496 !      include 'COMMON.CONTACTS'
12497       real(kind=8),parameter :: accur=1.0d-10
12498       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12499 !el local variables
12500       integer :: i,iint,j,k,itypi,itypi1,itypj
12501       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12502       real(kind=8) :: e1,e2,evdwij,evdw
12503 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12504       evdw=0.0D0
12505       do i=iatsc_s,iatsc_e
12506         itypi=itype(i,1)
12507         if (itypi.eq.ntyp1) cycle
12508         itypi1=itype(i+1,1)
12509         xi=c(1,nres+i)
12510         yi=c(2,nres+i)
12511         zi=c(3,nres+i)
12512 !
12513 ! Calculate SC interaction energy.
12514 !
12515         do iint=1,nint_gr(i)
12516 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12517 !d   &                  'iend=',iend(i,iint)
12518           do j=istart(i,iint),iend(i,iint)
12519             itypj=itype(j,1)
12520             if (itypj.eq.ntyp1) cycle
12521             xj=c(1,nres+j)-xi
12522             yj=c(2,nres+j)-yi
12523             zj=c(3,nres+j)-zi
12524             rij=xj*xj+yj*yj+zj*zj
12525             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12526             if (sss.lt.1.0d0) then
12527               rrij=1.0D0/rij
12528               eps0ij=eps(itypi,itypj)
12529               fac=rrij**expon2
12530               e1=fac*fac*aa_aq(itypi,itypj)
12531               e2=fac*bb_aq(itypi,itypj)
12532               evdwij=e1+e2
12533               evdw=evdw+(1.0d0-sss)*evdwij
12534 !
12535 ! Calculate the components of the gradient in DC and X
12536 !
12537               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12538               gg(1)=xj*fac
12539               gg(2)=yj*fac
12540               gg(3)=zj*fac
12541               do k=1,3
12542                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12543                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12544                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12545                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12546               enddo
12547             endif
12548           enddo      ! j
12549         enddo        ! iint
12550       enddo          ! i
12551       do i=1,nct
12552         do j=1,3
12553           gvdwc(j,i)=expon*gvdwc(j,i)
12554           gvdwx(j,i)=expon*gvdwx(j,i)
12555         enddo
12556       enddo
12557 !******************************************************************************
12558 !
12559 !                              N O T E !!!
12560 !
12561 ! To save time, the factor of EXPON has been extracted from ALL components
12562 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12563 ! use!
12564 !
12565 !******************************************************************************
12566       return
12567       end subroutine elj_long
12568 !-----------------------------------------------------------------------------
12569       subroutine elj_short(evdw)
12570 !
12571 ! This subroutine calculates the interaction energy of nonbonded side chains
12572 ! assuming the LJ potential of interaction.
12573 !
12574 !      implicit real*8 (a-h,o-z)
12575 !      include 'DIMENSIONS'
12576 !      include 'COMMON.GEO'
12577 !      include 'COMMON.VAR'
12578 !      include 'COMMON.LOCAL'
12579 !      include 'COMMON.CHAIN'
12580 !      include 'COMMON.DERIV'
12581 !      include 'COMMON.INTERACT'
12582 !      include 'COMMON.TORSION'
12583 !      include 'COMMON.SBRIDGE'
12584 !      include 'COMMON.NAMES'
12585 !      include 'COMMON.IOUNITS'
12586 !      include 'COMMON.CONTACTS'
12587       real(kind=8),parameter :: accur=1.0d-10
12588       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12589 !el local variables
12590       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12591       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12592       real(kind=8) :: e1,e2,evdwij,evdw
12593 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12594       evdw=0.0D0
12595       do i=iatsc_s,iatsc_e
12596         itypi=itype(i,1)
12597         if (itypi.eq.ntyp1) cycle
12598         itypi1=itype(i+1,1)
12599         xi=c(1,nres+i)
12600         yi=c(2,nres+i)
12601         zi=c(3,nres+i)
12602 ! Change 12/1/95
12603         num_conti=0
12604 !
12605 ! Calculate SC interaction energy.
12606 !
12607         do iint=1,nint_gr(i)
12608 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12609 !d   &                  'iend=',iend(i,iint)
12610           do j=istart(i,iint),iend(i,iint)
12611             itypj=itype(j,1)
12612             if (itypj.eq.ntyp1) cycle
12613             xj=c(1,nres+j)-xi
12614             yj=c(2,nres+j)-yi
12615             zj=c(3,nres+j)-zi
12616 ! Change 12/1/95 to calculate four-body interactions
12617             rij=xj*xj+yj*yj+zj*zj
12618             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12619             if (sss.gt.0.0d0) then
12620               rrij=1.0D0/rij
12621               eps0ij=eps(itypi,itypj)
12622               fac=rrij**expon2
12623               e1=fac*fac*aa_aq(itypi,itypj)
12624               e2=fac*bb_aq(itypi,itypj)
12625               evdwij=e1+e2
12626               evdw=evdw+sss*evdwij
12627 !
12628 ! Calculate the components of the gradient in DC and X
12629 !
12630               fac=-rrij*(e1+evdwij)*sss
12631               gg(1)=xj*fac
12632               gg(2)=yj*fac
12633               gg(3)=zj*fac
12634               do k=1,3
12635                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12636                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12637                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12638                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12639               enddo
12640             endif
12641           enddo      ! j
12642         enddo        ! iint
12643       enddo          ! i
12644       do i=1,nct
12645         do j=1,3
12646           gvdwc(j,i)=expon*gvdwc(j,i)
12647           gvdwx(j,i)=expon*gvdwx(j,i)
12648         enddo
12649       enddo
12650 !******************************************************************************
12651 !
12652 !                              N O T E !!!
12653 !
12654 ! To save time, the factor of EXPON has been extracted from ALL components
12655 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12656 ! use!
12657 !
12658 !******************************************************************************
12659       return
12660       end subroutine elj_short
12661 !-----------------------------------------------------------------------------
12662       subroutine eljk_long(evdw)
12663 !
12664 ! This subroutine calculates the interaction energy of nonbonded side chains
12665 ! assuming the LJK potential of interaction.
12666 !
12667 !      implicit real*8 (a-h,o-z)
12668 !      include 'DIMENSIONS'
12669 !      include 'COMMON.GEO'
12670 !      include 'COMMON.VAR'
12671 !      include 'COMMON.LOCAL'
12672 !      include 'COMMON.CHAIN'
12673 !      include 'COMMON.DERIV'
12674 !      include 'COMMON.INTERACT'
12675 !      include 'COMMON.IOUNITS'
12676 !      include 'COMMON.NAMES'
12677       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12678       logical :: scheck
12679 !el local variables
12680       integer :: i,iint,j,k,itypi,itypi1,itypj
12681       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12682                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12683 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12684       evdw=0.0D0
12685       do i=iatsc_s,iatsc_e
12686         itypi=itype(i,1)
12687         if (itypi.eq.ntyp1) cycle
12688         itypi1=itype(i+1,1)
12689         xi=c(1,nres+i)
12690         yi=c(2,nres+i)
12691         zi=c(3,nres+i)
12692 !
12693 ! Calculate SC interaction energy.
12694 !
12695         do iint=1,nint_gr(i)
12696           do j=istart(i,iint),iend(i,iint)
12697             itypj=itype(j,1)
12698             if (itypj.eq.ntyp1) cycle
12699             xj=c(1,nres+j)-xi
12700             yj=c(2,nres+j)-yi
12701             zj=c(3,nres+j)-zi
12702             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12703             fac_augm=rrij**expon
12704             e_augm=augm(itypi,itypj)*fac_augm
12705             r_inv_ij=dsqrt(rrij)
12706             rij=1.0D0/r_inv_ij
12707             sss=sscale(rij/sigma(itypi,itypj))
12708             if (sss.lt.1.0d0) then
12709               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12710               fac=r_shift_inv**expon
12711               e1=fac*fac*aa_aq(itypi,itypj)
12712               e2=fac*bb_aq(itypi,itypj)
12713               evdwij=e_augm+e1+e2
12714 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12715 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12716 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12717 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12718 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12719 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12720 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12721               evdw=evdw+(1.0d0-sss)*evdwij
12722 !
12723 ! Calculate the components of the gradient in DC and X
12724 !
12725               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12726               fac=fac*(1.0d0-sss)
12727               gg(1)=xj*fac
12728               gg(2)=yj*fac
12729               gg(3)=zj*fac
12730               do k=1,3
12731                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12732                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12733                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12734                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12735               enddo
12736             endif
12737           enddo      ! j
12738         enddo        ! iint
12739       enddo          ! i
12740       do i=1,nct
12741         do j=1,3
12742           gvdwc(j,i)=expon*gvdwc(j,i)
12743           gvdwx(j,i)=expon*gvdwx(j,i)
12744         enddo
12745       enddo
12746       return
12747       end subroutine eljk_long
12748 !-----------------------------------------------------------------------------
12749       subroutine eljk_short(evdw)
12750 !
12751 ! This subroutine calculates the interaction energy of nonbonded side chains
12752 ! assuming the LJK potential of interaction.
12753 !
12754 !      implicit real*8 (a-h,o-z)
12755 !      include 'DIMENSIONS'
12756 !      include 'COMMON.GEO'
12757 !      include 'COMMON.VAR'
12758 !      include 'COMMON.LOCAL'
12759 !      include 'COMMON.CHAIN'
12760 !      include 'COMMON.DERIV'
12761 !      include 'COMMON.INTERACT'
12762 !      include 'COMMON.IOUNITS'
12763 !      include 'COMMON.NAMES'
12764       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12765       logical :: scheck
12766 !el local variables
12767       integer :: i,iint,j,k,itypi,itypi1,itypj
12768       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12769                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12770 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12771       evdw=0.0D0
12772       do i=iatsc_s,iatsc_e
12773         itypi=itype(i,1)
12774         if (itypi.eq.ntyp1) cycle
12775         itypi1=itype(i+1,1)
12776         xi=c(1,nres+i)
12777         yi=c(2,nres+i)
12778         zi=c(3,nres+i)
12779 !
12780 ! Calculate SC interaction energy.
12781 !
12782         do iint=1,nint_gr(i)
12783           do j=istart(i,iint),iend(i,iint)
12784             itypj=itype(j,1)
12785             if (itypj.eq.ntyp1) cycle
12786             xj=c(1,nres+j)-xi
12787             yj=c(2,nres+j)-yi
12788             zj=c(3,nres+j)-zi
12789             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12790             fac_augm=rrij**expon
12791             e_augm=augm(itypi,itypj)*fac_augm
12792             r_inv_ij=dsqrt(rrij)
12793             rij=1.0D0/r_inv_ij
12794             sss=sscale(rij/sigma(itypi,itypj))
12795             if (sss.gt.0.0d0) then
12796               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12797               fac=r_shift_inv**expon
12798               e1=fac*fac*aa_aq(itypi,itypj)
12799               e2=fac*bb_aq(itypi,itypj)
12800               evdwij=e_augm+e1+e2
12801 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12802 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12803 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12804 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12805 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12806 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12807 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12808               evdw=evdw+sss*evdwij
12809 !
12810 ! Calculate the components of the gradient in DC and X
12811 !
12812               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12813               fac=fac*sss
12814               gg(1)=xj*fac
12815               gg(2)=yj*fac
12816               gg(3)=zj*fac
12817               do k=1,3
12818                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12819                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12820                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12821                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12822               enddo
12823             endif
12824           enddo      ! j
12825         enddo        ! iint
12826       enddo          ! i
12827       do i=1,nct
12828         do j=1,3
12829           gvdwc(j,i)=expon*gvdwc(j,i)
12830           gvdwx(j,i)=expon*gvdwx(j,i)
12831         enddo
12832       enddo
12833       return
12834       end subroutine eljk_short
12835 !-----------------------------------------------------------------------------
12836       subroutine ebp_long(evdw)
12837 !
12838 ! This subroutine calculates the interaction energy of nonbonded side chains
12839 ! assuming the Berne-Pechukas potential of interaction.
12840 !
12841       use calc_data
12842 !      implicit real*8 (a-h,o-z)
12843 !      include 'DIMENSIONS'
12844 !      include 'COMMON.GEO'
12845 !      include 'COMMON.VAR'
12846 !      include 'COMMON.LOCAL'
12847 !      include 'COMMON.CHAIN'
12848 !      include 'COMMON.DERIV'
12849 !      include 'COMMON.NAMES'
12850 !      include 'COMMON.INTERACT'
12851 !      include 'COMMON.IOUNITS'
12852 !      include 'COMMON.CALC'
12853       use comm_srutu
12854 !el      integer :: icall
12855 !el      common /srutu/ icall
12856 !     double precision rrsave(maxdim)
12857       logical :: lprn
12858 !el local variables
12859       integer :: iint,itypi,itypi1,itypj
12860       real(kind=8) :: rrij,xi,yi,zi,fac
12861       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12862       evdw=0.0D0
12863 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12864       evdw=0.0D0
12865 !     if (icall.eq.0) then
12866 !       lprn=.true.
12867 !     else
12868         lprn=.false.
12869 !     endif
12870 !el      ind=0
12871       do i=iatsc_s,iatsc_e
12872         itypi=itype(i,1)
12873         if (itypi.eq.ntyp1) cycle
12874         itypi1=itype(i+1,1)
12875         xi=c(1,nres+i)
12876         yi=c(2,nres+i)
12877         zi=c(3,nres+i)
12878         dxi=dc_norm(1,nres+i)
12879         dyi=dc_norm(2,nres+i)
12880         dzi=dc_norm(3,nres+i)
12881 !        dsci_inv=dsc_inv(itypi)
12882         dsci_inv=vbld_inv(i+nres)
12883 !
12884 ! Calculate SC interaction energy.
12885 !
12886         do iint=1,nint_gr(i)
12887           do j=istart(i,iint),iend(i,iint)
12888 !el            ind=ind+1
12889             itypj=itype(j,1)
12890             if (itypj.eq.ntyp1) cycle
12891 !            dscj_inv=dsc_inv(itypj)
12892             dscj_inv=vbld_inv(j+nres)
12893             chi1=chi(itypi,itypj)
12894             chi2=chi(itypj,itypi)
12895             chi12=chi1*chi2
12896             chip1=chip(itypi)
12897             chip2=chip(itypj)
12898             chip12=chip1*chip2
12899             alf1=alp(itypi)
12900             alf2=alp(itypj)
12901             alf12=0.5D0*(alf1+alf2)
12902             xj=c(1,nres+j)-xi
12903             yj=c(2,nres+j)-yi
12904             zj=c(3,nres+j)-zi
12905             dxj=dc_norm(1,nres+j)
12906             dyj=dc_norm(2,nres+j)
12907             dzj=dc_norm(3,nres+j)
12908             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12909             rij=dsqrt(rrij)
12910             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12911
12912             if (sss.lt.1.0d0) then
12913
12914 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12915               call sc_angular
12916 ! Calculate whole angle-dependent part of epsilon and contributions
12917 ! to its derivatives
12918               fac=(rrij*sigsq)**expon2
12919               e1=fac*fac*aa_aq(itypi,itypj)
12920               e2=fac*bb_aq(itypi,itypj)
12921               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12922               eps2der=evdwij*eps3rt
12923               eps3der=evdwij*eps2rt
12924               evdwij=evdwij*eps2rt*eps3rt
12925               evdw=evdw+evdwij*(1.0d0-sss)
12926               if (lprn) then
12927               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12928               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12929 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12930 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12931 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12932 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12933 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12934 !d     &          evdwij
12935               endif
12936 ! Calculate gradient components.
12937               e1=e1*eps1*eps2rt**2*eps3rt**2
12938               fac=-expon*(e1+evdwij)
12939               sigder=fac/sigsq
12940               fac=rrij*fac
12941 ! Calculate radial part of the gradient
12942               gg(1)=xj*fac
12943               gg(2)=yj*fac
12944               gg(3)=zj*fac
12945 ! Calculate the angular part of the gradient and sum add the contributions
12946 ! to the appropriate components of the Cartesian gradient.
12947               call sc_grad_scale(1.0d0-sss)
12948             endif
12949           enddo      ! j
12950         enddo        ! iint
12951       enddo          ! i
12952 !     stop
12953       return
12954       end subroutine ebp_long
12955 !-----------------------------------------------------------------------------
12956       subroutine ebp_short(evdw)
12957 !
12958 ! This subroutine calculates the interaction energy of nonbonded side chains
12959 ! assuming the Berne-Pechukas potential of interaction.
12960 !
12961       use calc_data
12962 !      implicit real*8 (a-h,o-z)
12963 !      include 'DIMENSIONS'
12964 !      include 'COMMON.GEO'
12965 !      include 'COMMON.VAR'
12966 !      include 'COMMON.LOCAL'
12967 !      include 'COMMON.CHAIN'
12968 !      include 'COMMON.DERIV'
12969 !      include 'COMMON.NAMES'
12970 !      include 'COMMON.INTERACT'
12971 !      include 'COMMON.IOUNITS'
12972 !      include 'COMMON.CALC'
12973       use comm_srutu
12974 !el      integer :: icall
12975 !el      common /srutu/ icall
12976 !     double precision rrsave(maxdim)
12977       logical :: lprn
12978 !el local variables
12979       integer :: iint,itypi,itypi1,itypj
12980       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12981       real(kind=8) :: sss,e1,e2,evdw
12982       evdw=0.0D0
12983 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12984       evdw=0.0D0
12985 !     if (icall.eq.0) then
12986 !       lprn=.true.
12987 !     else
12988         lprn=.false.
12989 !     endif
12990 !el      ind=0
12991       do i=iatsc_s,iatsc_e
12992         itypi=itype(i,1)
12993         if (itypi.eq.ntyp1) cycle
12994         itypi1=itype(i+1,1)
12995         xi=c(1,nres+i)
12996         yi=c(2,nres+i)
12997         zi=c(3,nres+i)
12998         dxi=dc_norm(1,nres+i)
12999         dyi=dc_norm(2,nres+i)
13000         dzi=dc_norm(3,nres+i)
13001 !        dsci_inv=dsc_inv(itypi)
13002         dsci_inv=vbld_inv(i+nres)
13003 !
13004 ! Calculate SC interaction energy.
13005 !
13006         do iint=1,nint_gr(i)
13007           do j=istart(i,iint),iend(i,iint)
13008 !el            ind=ind+1
13009             itypj=itype(j,1)
13010             if (itypj.eq.ntyp1) cycle
13011 !            dscj_inv=dsc_inv(itypj)
13012             dscj_inv=vbld_inv(j+nres)
13013             chi1=chi(itypi,itypj)
13014             chi2=chi(itypj,itypi)
13015             chi12=chi1*chi2
13016             chip1=chip(itypi)
13017             chip2=chip(itypj)
13018             chip12=chip1*chip2
13019             alf1=alp(itypi)
13020             alf2=alp(itypj)
13021             alf12=0.5D0*(alf1+alf2)
13022             xj=c(1,nres+j)-xi
13023             yj=c(2,nres+j)-yi
13024             zj=c(3,nres+j)-zi
13025             dxj=dc_norm(1,nres+j)
13026             dyj=dc_norm(2,nres+j)
13027             dzj=dc_norm(3,nres+j)
13028             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13029             rij=dsqrt(rrij)
13030             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13031
13032             if (sss.gt.0.0d0) then
13033
13034 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13035               call sc_angular
13036 ! Calculate whole angle-dependent part of epsilon and contributions
13037 ! to its derivatives
13038               fac=(rrij*sigsq)**expon2
13039               e1=fac*fac*aa_aq(itypi,itypj)
13040               e2=fac*bb_aq(itypi,itypj)
13041               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13042               eps2der=evdwij*eps3rt
13043               eps3der=evdwij*eps2rt
13044               evdwij=evdwij*eps2rt*eps3rt
13045               evdw=evdw+evdwij*sss
13046               if (lprn) then
13047               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13048               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13049 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13050 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13051 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13052 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13053 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13054 !d     &          evdwij
13055               endif
13056 ! Calculate gradient components.
13057               e1=e1*eps1*eps2rt**2*eps3rt**2
13058               fac=-expon*(e1+evdwij)
13059               sigder=fac/sigsq
13060               fac=rrij*fac
13061 ! Calculate radial part of the gradient
13062               gg(1)=xj*fac
13063               gg(2)=yj*fac
13064               gg(3)=zj*fac
13065 ! Calculate the angular part of the gradient and sum add the contributions
13066 ! to the appropriate components of the Cartesian gradient.
13067               call sc_grad_scale(sss)
13068             endif
13069           enddo      ! j
13070         enddo        ! iint
13071       enddo          ! i
13072 !     stop
13073       return
13074       end subroutine ebp_short
13075 !-----------------------------------------------------------------------------
13076       subroutine egb_long(evdw)
13077 !
13078 ! This subroutine calculates the interaction energy of nonbonded side chains
13079 ! assuming the Gay-Berne potential of interaction.
13080 !
13081       use calc_data
13082 !      implicit real*8 (a-h,o-z)
13083 !      include 'DIMENSIONS'
13084 !      include 'COMMON.GEO'
13085 !      include 'COMMON.VAR'
13086 !      include 'COMMON.LOCAL'
13087 !      include 'COMMON.CHAIN'
13088 !      include 'COMMON.DERIV'
13089 !      include 'COMMON.NAMES'
13090 !      include 'COMMON.INTERACT'
13091 !      include 'COMMON.IOUNITS'
13092 !      include 'COMMON.CALC'
13093 !      include 'COMMON.CONTROL'
13094       logical :: lprn
13095 !el local variables
13096       integer :: iint,itypi,itypi1,itypj,subchap
13097       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13098       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13099       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13100                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13101                     ssgradlipi,ssgradlipj
13102
13103
13104       evdw=0.0D0
13105 !cccc      energy_dec=.false.
13106 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13107       evdw=0.0D0
13108       lprn=.false.
13109 !     if (icall.eq.0) lprn=.false.
13110 !el      ind=0
13111       do i=iatsc_s,iatsc_e
13112         itypi=itype(i,1)
13113         if (itypi.eq.ntyp1) cycle
13114         itypi1=itype(i+1,1)
13115         xi=c(1,nres+i)
13116         yi=c(2,nres+i)
13117         zi=c(3,nres+i)
13118           xi=mod(xi,boxxsize)
13119           if (xi.lt.0) xi=xi+boxxsize
13120           yi=mod(yi,boxysize)
13121           if (yi.lt.0) yi=yi+boxysize
13122           zi=mod(zi,boxzsize)
13123           if (zi.lt.0) zi=zi+boxzsize
13124        if ((zi.gt.bordlipbot)    &
13125         .and.(zi.lt.bordliptop)) then
13126 !C the energy transfer exist
13127         if (zi.lt.buflipbot) then
13128 !C what fraction I am in
13129          fracinbuf=1.0d0-    &
13130              ((zi-bordlipbot)/lipbufthick)
13131 !C lipbufthick is thickenes of lipid buffore
13132          sslipi=sscalelip(fracinbuf)
13133          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13134         elseif (zi.gt.bufliptop) then
13135          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13136          sslipi=sscalelip(fracinbuf)
13137          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13138         else
13139          sslipi=1.0d0
13140          ssgradlipi=0.0
13141         endif
13142        else
13143          sslipi=0.0d0
13144          ssgradlipi=0.0
13145        endif
13146
13147         dxi=dc_norm(1,nres+i)
13148         dyi=dc_norm(2,nres+i)
13149         dzi=dc_norm(3,nres+i)
13150 !        dsci_inv=dsc_inv(itypi)
13151         dsci_inv=vbld_inv(i+nres)
13152 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13153 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13154 !
13155 ! Calculate SC interaction energy.
13156 !
13157         do iint=1,nint_gr(i)
13158           do j=istart(i,iint),iend(i,iint)
13159             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13160 !              call dyn_ssbond_ene(i,j,evdwij)
13161 !              evdw=evdw+evdwij
13162 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13163 !                              'evdw',i,j,evdwij,' ss'
13164 !              if (energy_dec) write (iout,*) &
13165 !                              'evdw',i,j,evdwij,' ss'
13166 !             do k=j+1,iend(i,iint)
13167 !C search over all next residues
13168 !              if (dyn_ss_mask(k)) then
13169 !C check if they are cysteins
13170 !C              write(iout,*) 'k=',k
13171
13172 !c              write(iout,*) "PRZED TRI", evdwij
13173 !               evdwij_przed_tri=evdwij
13174 !              call triple_ssbond_ene(i,j,k,evdwij)
13175 !c               if(evdwij_przed_tri.ne.evdwij) then
13176 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13177 !c               endif
13178
13179 !c              write(iout,*) "PO TRI", evdwij
13180 !C call the energy function that removes the artifical triple disulfide
13181 !C bond the soubroutine is located in ssMD.F
13182 !              evdw=evdw+evdwij
13183               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13184                             'evdw',i,j,evdwij,'tss'
13185 !              endif!dyn_ss_mask(k)
13186 !             enddo! k
13187
13188             ELSE
13189 !el            ind=ind+1
13190             itypj=itype(j,1)
13191             if (itypj.eq.ntyp1) cycle
13192 !            dscj_inv=dsc_inv(itypj)
13193             dscj_inv=vbld_inv(j+nres)
13194 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13195 !     &       1.0d0/vbld(j+nres)
13196 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13197             sig0ij=sigma(itypi,itypj)
13198             chi1=chi(itypi,itypj)
13199             chi2=chi(itypj,itypi)
13200             chi12=chi1*chi2
13201             chip1=chip(itypi)
13202             chip2=chip(itypj)
13203             chip12=chip1*chip2
13204             alf1=alp(itypi)
13205             alf2=alp(itypj)
13206             alf12=0.5D0*(alf1+alf2)
13207             xj=c(1,nres+j)
13208             yj=c(2,nres+j)
13209             zj=c(3,nres+j)
13210 ! Searching for nearest neighbour
13211           xj=mod(xj,boxxsize)
13212           if (xj.lt.0) xj=xj+boxxsize
13213           yj=mod(yj,boxysize)
13214           if (yj.lt.0) yj=yj+boxysize
13215           zj=mod(zj,boxzsize)
13216           if (zj.lt.0) zj=zj+boxzsize
13217        if ((zj.gt.bordlipbot)   &
13218       .and.(zj.lt.bordliptop)) then
13219 !C the energy transfer exist
13220         if (zj.lt.buflipbot) then
13221 !C what fraction I am in
13222          fracinbuf=1.0d0-  &
13223              ((zj-bordlipbot)/lipbufthick)
13224 !C lipbufthick is thickenes of lipid buffore
13225          sslipj=sscalelip(fracinbuf)
13226          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13227         elseif (zj.gt.bufliptop) then
13228          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13229          sslipj=sscalelip(fracinbuf)
13230          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13231         else
13232          sslipj=1.0d0
13233          ssgradlipj=0.0
13234         endif
13235        else
13236          sslipj=0.0d0
13237          ssgradlipj=0.0
13238        endif
13239       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13240        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13241       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13242        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13243
13244           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13245           xj_safe=xj
13246           yj_safe=yj
13247           zj_safe=zj
13248           subchap=0
13249           do xshift=-1,1
13250           do yshift=-1,1
13251           do zshift=-1,1
13252           xj=xj_safe+xshift*boxxsize
13253           yj=yj_safe+yshift*boxysize
13254           zj=zj_safe+zshift*boxzsize
13255           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13256           if(dist_temp.lt.dist_init) then
13257             dist_init=dist_temp
13258             xj_temp=xj
13259             yj_temp=yj
13260             zj_temp=zj
13261             subchap=1
13262           endif
13263           enddo
13264           enddo
13265           enddo
13266           if (subchap.eq.1) then
13267           xj=xj_temp-xi
13268           yj=yj_temp-yi
13269           zj=zj_temp-zi
13270           else
13271           xj=xj_safe-xi
13272           yj=yj_safe-yi
13273           zj=zj_safe-zi
13274           endif
13275
13276             dxj=dc_norm(1,nres+j)
13277             dyj=dc_norm(2,nres+j)
13278             dzj=dc_norm(3,nres+j)
13279             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13280             rij=dsqrt(rrij)
13281             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13282             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13283             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13284             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13285             if (sss_ele_cut.le.0.0) cycle
13286             if (sss.lt.1.0d0) then
13287
13288 ! Calculate angle-dependent terms of energy and contributions to their
13289 ! derivatives.
13290               call sc_angular
13291               sigsq=1.0D0/sigsq
13292               sig=sig0ij*dsqrt(sigsq)
13293               rij_shift=1.0D0/rij-sig+sig0ij
13294 ! for diagnostics; uncomment
13295 !              rij_shift=1.2*sig0ij
13296 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13297               if (rij_shift.le.0.0D0) then
13298                 evdw=1.0D20
13299 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13300 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13301 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13302                 return
13303               endif
13304               sigder=-sig*sigsq
13305 !---------------------------------------------------------------
13306               rij_shift=1.0D0/rij_shift
13307               fac=rij_shift**expon
13308               e1=fac*fac*aa
13309               e2=fac*bb
13310               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13311               eps2der=evdwij*eps3rt
13312               eps3der=evdwij*eps2rt
13313 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13314 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13315               evdwij=evdwij*eps2rt*eps3rt
13316               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13317               if (lprn) then
13318               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13319               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13320               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13321                 restyp(itypi,1),i,restyp(itypj,1),j,&
13322                 epsi,sigm,chi1,chi2,chip1,chip2,&
13323                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13324                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13325                 evdwij
13326               endif
13327
13328               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13329                               'evdw',i,j,evdwij
13330 !              if (energy_dec) write (iout,*) &
13331 !                              'evdw',i,j,evdwij,"egb_long"
13332
13333 ! Calculate gradient components.
13334               e1=e1*eps1*eps2rt**2*eps3rt**2
13335               fac=-expon*(e1+evdwij)*rij_shift
13336               sigder=fac*sigder
13337               fac=rij*fac
13338               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13339             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13340             /sigmaii(itypi,itypj))
13341 !              fac=0.0d0
13342 ! Calculate the radial part of the gradient
13343               gg(1)=xj*fac
13344               gg(2)=yj*fac
13345               gg(3)=zj*fac
13346 ! Calculate angular part of the gradient.
13347               call sc_grad_scale(1.0d0-sss)
13348             ENDIF    !mask_dyn_ss
13349             endif
13350           enddo      ! j
13351         enddo        ! iint
13352       enddo          ! i
13353 !      write (iout,*) "Number of loop steps in EGB:",ind
13354 !ccc      energy_dec=.false.
13355       return
13356       end subroutine egb_long
13357 !-----------------------------------------------------------------------------
13358       subroutine egb_short(evdw)
13359 !
13360 ! This subroutine calculates the interaction energy of nonbonded side chains
13361 ! assuming the Gay-Berne potential of interaction.
13362 !
13363       use calc_data
13364 !      implicit real*8 (a-h,o-z)
13365 !      include 'DIMENSIONS'
13366 !      include 'COMMON.GEO'
13367 !      include 'COMMON.VAR'
13368 !      include 'COMMON.LOCAL'
13369 !      include 'COMMON.CHAIN'
13370 !      include 'COMMON.DERIV'
13371 !      include 'COMMON.NAMES'
13372 !      include 'COMMON.INTERACT'
13373 !      include 'COMMON.IOUNITS'
13374 !      include 'COMMON.CALC'
13375 !      include 'COMMON.CONTROL'
13376       logical :: lprn
13377 !el local variables
13378       integer :: iint,itypi,itypi1,itypj,subchap
13379       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13380       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13381       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13382                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13383                     ssgradlipi,ssgradlipj
13384       evdw=0.0D0
13385 !cccc      energy_dec=.false.
13386 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13387       evdw=0.0D0
13388       lprn=.false.
13389 !     if (icall.eq.0) lprn=.false.
13390 !el      ind=0
13391       do i=iatsc_s,iatsc_e
13392         itypi=itype(i,1)
13393         if (itypi.eq.ntyp1) cycle
13394         itypi1=itype(i+1,1)
13395         xi=c(1,nres+i)
13396         yi=c(2,nres+i)
13397         zi=c(3,nres+i)
13398           xi=mod(xi,boxxsize)
13399           if (xi.lt.0) xi=xi+boxxsize
13400           yi=mod(yi,boxysize)
13401           if (yi.lt.0) yi=yi+boxysize
13402           zi=mod(zi,boxzsize)
13403           if (zi.lt.0) zi=zi+boxzsize
13404        if ((zi.gt.bordlipbot)    &
13405         .and.(zi.lt.bordliptop)) then
13406 !C the energy transfer exist
13407         if (zi.lt.buflipbot) then
13408 !C what fraction I am in
13409          fracinbuf=1.0d0-    &
13410              ((zi-bordlipbot)/lipbufthick)
13411 !C lipbufthick is thickenes of lipid buffore
13412          sslipi=sscalelip(fracinbuf)
13413          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13414         elseif (zi.gt.bufliptop) then
13415          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13416          sslipi=sscalelip(fracinbuf)
13417          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13418         else
13419          sslipi=1.0d0
13420          ssgradlipi=0.0
13421         endif
13422        else
13423          sslipi=0.0d0
13424          ssgradlipi=0.0
13425        endif
13426
13427         dxi=dc_norm(1,nres+i)
13428         dyi=dc_norm(2,nres+i)
13429         dzi=dc_norm(3,nres+i)
13430 !        dsci_inv=dsc_inv(itypi)
13431         dsci_inv=vbld_inv(i+nres)
13432
13433         dxi=dc_norm(1,nres+i)
13434         dyi=dc_norm(2,nres+i)
13435         dzi=dc_norm(3,nres+i)
13436 !        dsci_inv=dsc_inv(itypi)
13437         dsci_inv=vbld_inv(i+nres)
13438 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13439 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13440 !
13441 ! Calculate SC interaction energy.
13442 !
13443         do iint=1,nint_gr(i)
13444           do j=istart(i,iint),iend(i,iint)
13445             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13446               call dyn_ssbond_ene(i,j,evdwij)
13447               evdw=evdw+evdwij
13448               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13449                               'evdw',i,j,evdwij,' ss'
13450              do k=j+1,iend(i,iint)
13451 !C search over all next residues
13452               if (dyn_ss_mask(k)) then
13453 !C check if they are cysteins
13454 !C              write(iout,*) 'k=',k
13455
13456 !c              write(iout,*) "PRZED TRI", evdwij
13457 !               evdwij_przed_tri=evdwij
13458               call triple_ssbond_ene(i,j,k,evdwij)
13459 !c               if(evdwij_przed_tri.ne.evdwij) then
13460 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13461 !c               endif
13462
13463 !c              write(iout,*) "PO TRI", evdwij
13464 !C call the energy function that removes the artifical triple disulfide
13465 !C bond the soubroutine is located in ssMD.F
13466               evdw=evdw+evdwij
13467               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13468                             'evdw',i,j,evdwij,'tss'
13469               endif!dyn_ss_mask(k)
13470              enddo! k
13471
13472 !              if (energy_dec) write (iout,*) &
13473 !                              'evdw',i,j,evdwij,' ss'
13474             ELSE
13475 !el            ind=ind+1
13476             itypj=itype(j,1)
13477             if (itypj.eq.ntyp1) cycle
13478 !            dscj_inv=dsc_inv(itypj)
13479             dscj_inv=vbld_inv(j+nres)
13480 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13481 !     &       1.0d0/vbld(j+nres)
13482 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13483             sig0ij=sigma(itypi,itypj)
13484             chi1=chi(itypi,itypj)
13485             chi2=chi(itypj,itypi)
13486             chi12=chi1*chi2
13487             chip1=chip(itypi)
13488             chip2=chip(itypj)
13489             chip12=chip1*chip2
13490             alf1=alp(itypi)
13491             alf2=alp(itypj)
13492             alf12=0.5D0*(alf1+alf2)
13493 !            xj=c(1,nres+j)-xi
13494 !            yj=c(2,nres+j)-yi
13495 !            zj=c(3,nres+j)-zi
13496             xj=c(1,nres+j)
13497             yj=c(2,nres+j)
13498             zj=c(3,nres+j)
13499 ! Searching for nearest neighbour
13500           xj=mod(xj,boxxsize)
13501           if (xj.lt.0) xj=xj+boxxsize
13502           yj=mod(yj,boxysize)
13503           if (yj.lt.0) yj=yj+boxysize
13504           zj=mod(zj,boxzsize)
13505           if (zj.lt.0) zj=zj+boxzsize
13506        if ((zj.gt.bordlipbot)   &
13507       .and.(zj.lt.bordliptop)) then
13508 !C the energy transfer exist
13509         if (zj.lt.buflipbot) then
13510 !C what fraction I am in
13511          fracinbuf=1.0d0-  &
13512              ((zj-bordlipbot)/lipbufthick)
13513 !C lipbufthick is thickenes of lipid buffore
13514          sslipj=sscalelip(fracinbuf)
13515          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13516         elseif (zj.gt.bufliptop) then
13517          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13518          sslipj=sscalelip(fracinbuf)
13519          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13520         else
13521          sslipj=1.0d0
13522          ssgradlipj=0.0
13523         endif
13524        else
13525          sslipj=0.0d0
13526          ssgradlipj=0.0
13527        endif
13528       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13529        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13530       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13531        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13532
13533           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13534           xj_safe=xj
13535           yj_safe=yj
13536           zj_safe=zj
13537           subchap=0
13538
13539           do xshift=-1,1
13540           do yshift=-1,1
13541           do zshift=-1,1
13542           xj=xj_safe+xshift*boxxsize
13543           yj=yj_safe+yshift*boxysize
13544           zj=zj_safe+zshift*boxzsize
13545           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13546           if(dist_temp.lt.dist_init) then
13547             dist_init=dist_temp
13548             xj_temp=xj
13549             yj_temp=yj
13550             zj_temp=zj
13551             subchap=1
13552           endif
13553           enddo
13554           enddo
13555           enddo
13556           if (subchap.eq.1) then
13557           xj=xj_temp-xi
13558           yj=yj_temp-yi
13559           zj=zj_temp-zi
13560           else
13561           xj=xj_safe-xi
13562           yj=yj_safe-yi
13563           zj=zj_safe-zi
13564           endif
13565
13566             dxj=dc_norm(1,nres+j)
13567             dyj=dc_norm(2,nres+j)
13568             dzj=dc_norm(3,nres+j)
13569             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13570             rij=dsqrt(rrij)
13571             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13572             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13573             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13574             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13575             if (sss_ele_cut.le.0.0) cycle
13576
13577             if (sss.gt.0.0d0) then
13578
13579 ! Calculate angle-dependent terms of energy and contributions to their
13580 ! derivatives.
13581               call sc_angular
13582               sigsq=1.0D0/sigsq
13583               sig=sig0ij*dsqrt(sigsq)
13584               rij_shift=1.0D0/rij-sig+sig0ij
13585 ! for diagnostics; uncomment
13586 !              rij_shift=1.2*sig0ij
13587 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13588               if (rij_shift.le.0.0D0) then
13589                 evdw=1.0D20
13590 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13591 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13592 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13593                 return
13594               endif
13595               sigder=-sig*sigsq
13596 !---------------------------------------------------------------
13597               rij_shift=1.0D0/rij_shift
13598               fac=rij_shift**expon
13599               e1=fac*fac*aa
13600               e2=fac*bb
13601               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13602               eps2der=evdwij*eps3rt
13603               eps3der=evdwij*eps2rt
13604 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13605 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13606               evdwij=evdwij*eps2rt*eps3rt
13607               evdw=evdw+evdwij*sss*sss_ele_cut
13608               if (lprn) then
13609               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13610               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13611               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13612                 restyp(itypi,1),i,restyp(itypj,1),j,&
13613                 epsi,sigm,chi1,chi2,chip1,chip2,&
13614                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13615                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13616                 evdwij
13617               endif
13618
13619               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13620                               'evdw',i,j,evdwij
13621 !              if (energy_dec) write (iout,*) &
13622 !                              'evdw',i,j,evdwij,"egb_short"
13623
13624 ! Calculate gradient components.
13625               e1=e1*eps1*eps2rt**2*eps3rt**2
13626               fac=-expon*(e1+evdwij)*rij_shift
13627               sigder=fac*sigder
13628               fac=rij*fac
13629               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13630             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13631             /sigmaii(itypi,itypj))
13632
13633 !              fac=0.0d0
13634 ! Calculate the radial part of the gradient
13635               gg(1)=xj*fac
13636               gg(2)=yj*fac
13637               gg(3)=zj*fac
13638 ! Calculate angular part of the gradient.
13639               call sc_grad_scale(sss)
13640             endif
13641           ENDIF !mask_dyn_ss
13642           enddo      ! j
13643         enddo        ! iint
13644       enddo          ! i
13645 !      write (iout,*) "Number of loop steps in EGB:",ind
13646 !ccc      energy_dec=.false.
13647       return
13648       end subroutine egb_short
13649 !-----------------------------------------------------------------------------
13650       subroutine egbv_long(evdw)
13651 !
13652 ! This subroutine calculates the interaction energy of nonbonded side chains
13653 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13654 !
13655       use calc_data
13656 !      implicit real*8 (a-h,o-z)
13657 !      include 'DIMENSIONS'
13658 !      include 'COMMON.GEO'
13659 !      include 'COMMON.VAR'
13660 !      include 'COMMON.LOCAL'
13661 !      include 'COMMON.CHAIN'
13662 !      include 'COMMON.DERIV'
13663 !      include 'COMMON.NAMES'
13664 !      include 'COMMON.INTERACT'
13665 !      include 'COMMON.IOUNITS'
13666 !      include 'COMMON.CALC'
13667       use comm_srutu
13668 !el      integer :: icall
13669 !el      common /srutu/ icall
13670       logical :: lprn
13671 !el local variables
13672       integer :: iint,itypi,itypi1,itypj
13673       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13674       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13675       evdw=0.0D0
13676 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13677       evdw=0.0D0
13678       lprn=.false.
13679 !     if (icall.eq.0) lprn=.true.
13680 !el      ind=0
13681       do i=iatsc_s,iatsc_e
13682         itypi=itype(i,1)
13683         if (itypi.eq.ntyp1) cycle
13684         itypi1=itype(i+1,1)
13685         xi=c(1,nres+i)
13686         yi=c(2,nres+i)
13687         zi=c(3,nres+i)
13688         dxi=dc_norm(1,nres+i)
13689         dyi=dc_norm(2,nres+i)
13690         dzi=dc_norm(3,nres+i)
13691 !        dsci_inv=dsc_inv(itypi)
13692         dsci_inv=vbld_inv(i+nres)
13693 !
13694 ! Calculate SC interaction energy.
13695 !
13696         do iint=1,nint_gr(i)
13697           do j=istart(i,iint),iend(i,iint)
13698 !el            ind=ind+1
13699             itypj=itype(j,1)
13700             if (itypj.eq.ntyp1) cycle
13701 !            dscj_inv=dsc_inv(itypj)
13702             dscj_inv=vbld_inv(j+nres)
13703             sig0ij=sigma(itypi,itypj)
13704             r0ij=r0(itypi,itypj)
13705             chi1=chi(itypi,itypj)
13706             chi2=chi(itypj,itypi)
13707             chi12=chi1*chi2
13708             chip1=chip(itypi)
13709             chip2=chip(itypj)
13710             chip12=chip1*chip2
13711             alf1=alp(itypi)
13712             alf2=alp(itypj)
13713             alf12=0.5D0*(alf1+alf2)
13714             xj=c(1,nres+j)-xi
13715             yj=c(2,nres+j)-yi
13716             zj=c(3,nres+j)-zi
13717             dxj=dc_norm(1,nres+j)
13718             dyj=dc_norm(2,nres+j)
13719             dzj=dc_norm(3,nres+j)
13720             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13721             rij=dsqrt(rrij)
13722
13723             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13724
13725             if (sss.lt.1.0d0) then
13726
13727 ! Calculate angle-dependent terms of energy and contributions to their
13728 ! derivatives.
13729               call sc_angular
13730               sigsq=1.0D0/sigsq
13731               sig=sig0ij*dsqrt(sigsq)
13732               rij_shift=1.0D0/rij-sig+r0ij
13733 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13734               if (rij_shift.le.0.0D0) then
13735                 evdw=1.0D20
13736                 return
13737               endif
13738               sigder=-sig*sigsq
13739 !---------------------------------------------------------------
13740               rij_shift=1.0D0/rij_shift
13741               fac=rij_shift**expon
13742               e1=fac*fac*aa_aq(itypi,itypj)
13743               e2=fac*bb_aq(itypi,itypj)
13744               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13745               eps2der=evdwij*eps3rt
13746               eps3der=evdwij*eps2rt
13747               fac_augm=rrij**expon
13748               e_augm=augm(itypi,itypj)*fac_augm
13749               evdwij=evdwij*eps2rt*eps3rt
13750               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13751               if (lprn) then
13752               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13753               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13754               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13755                 restyp(itypi,1),i,restyp(itypj,1),j,&
13756                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13757                 chi1,chi2,chip1,chip2,&
13758                 eps1,eps2rt**2,eps3rt**2,&
13759                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13760                 evdwij+e_augm
13761               endif
13762 ! Calculate gradient components.
13763               e1=e1*eps1*eps2rt**2*eps3rt**2
13764               fac=-expon*(e1+evdwij)*rij_shift
13765               sigder=fac*sigder
13766               fac=rij*fac-2*expon*rrij*e_augm
13767 ! Calculate the radial part of the gradient
13768               gg(1)=xj*fac
13769               gg(2)=yj*fac
13770               gg(3)=zj*fac
13771 ! Calculate angular part of the gradient.
13772               call sc_grad_scale(1.0d0-sss)
13773             endif
13774           enddo      ! j
13775         enddo        ! iint
13776       enddo          ! i
13777       end subroutine egbv_long
13778 !-----------------------------------------------------------------------------
13779       subroutine egbv_short(evdw)
13780 !
13781 ! This subroutine calculates the interaction energy of nonbonded side chains
13782 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13783 !
13784       use calc_data
13785 !      implicit real*8 (a-h,o-z)
13786 !      include 'DIMENSIONS'
13787 !      include 'COMMON.GEO'
13788 !      include 'COMMON.VAR'
13789 !      include 'COMMON.LOCAL'
13790 !      include 'COMMON.CHAIN'
13791 !      include 'COMMON.DERIV'
13792 !      include 'COMMON.NAMES'
13793 !      include 'COMMON.INTERACT'
13794 !      include 'COMMON.IOUNITS'
13795 !      include 'COMMON.CALC'
13796       use comm_srutu
13797 !el      integer :: icall
13798 !el      common /srutu/ icall
13799       logical :: lprn
13800 !el local variables
13801       integer :: iint,itypi,itypi1,itypj
13802       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13803       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13804       evdw=0.0D0
13805 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13806       evdw=0.0D0
13807       lprn=.false.
13808 !     if (icall.eq.0) lprn=.true.
13809 !el      ind=0
13810       do i=iatsc_s,iatsc_e
13811         itypi=itype(i,1)
13812         if (itypi.eq.ntyp1) cycle
13813         itypi1=itype(i+1,1)
13814         xi=c(1,nres+i)
13815         yi=c(2,nres+i)
13816         zi=c(3,nres+i)
13817         dxi=dc_norm(1,nres+i)
13818         dyi=dc_norm(2,nres+i)
13819         dzi=dc_norm(3,nres+i)
13820 !        dsci_inv=dsc_inv(itypi)
13821         dsci_inv=vbld_inv(i+nres)
13822 !
13823 ! Calculate SC interaction energy.
13824 !
13825         do iint=1,nint_gr(i)
13826           do j=istart(i,iint),iend(i,iint)
13827 !el            ind=ind+1
13828             itypj=itype(j,1)
13829             if (itypj.eq.ntyp1) cycle
13830 !            dscj_inv=dsc_inv(itypj)
13831             dscj_inv=vbld_inv(j+nres)
13832             sig0ij=sigma(itypi,itypj)
13833             r0ij=r0(itypi,itypj)
13834             chi1=chi(itypi,itypj)
13835             chi2=chi(itypj,itypi)
13836             chi12=chi1*chi2
13837             chip1=chip(itypi)
13838             chip2=chip(itypj)
13839             chip12=chip1*chip2
13840             alf1=alp(itypi)
13841             alf2=alp(itypj)
13842             alf12=0.5D0*(alf1+alf2)
13843             xj=c(1,nres+j)-xi
13844             yj=c(2,nres+j)-yi
13845             zj=c(3,nres+j)-zi
13846             dxj=dc_norm(1,nres+j)
13847             dyj=dc_norm(2,nres+j)
13848             dzj=dc_norm(3,nres+j)
13849             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13850             rij=dsqrt(rrij)
13851
13852             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13853
13854             if (sss.gt.0.0d0) then
13855
13856 ! Calculate angle-dependent terms of energy and contributions to their
13857 ! derivatives.
13858               call sc_angular
13859               sigsq=1.0D0/sigsq
13860               sig=sig0ij*dsqrt(sigsq)
13861               rij_shift=1.0D0/rij-sig+r0ij
13862 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13863               if (rij_shift.le.0.0D0) then
13864                 evdw=1.0D20
13865                 return
13866               endif
13867               sigder=-sig*sigsq
13868 !---------------------------------------------------------------
13869               rij_shift=1.0D0/rij_shift
13870               fac=rij_shift**expon
13871               e1=fac*fac*aa_aq(itypi,itypj)
13872               e2=fac*bb_aq(itypi,itypj)
13873               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13874               eps2der=evdwij*eps3rt
13875               eps3der=evdwij*eps2rt
13876               fac_augm=rrij**expon
13877               e_augm=augm(itypi,itypj)*fac_augm
13878               evdwij=evdwij*eps2rt*eps3rt
13879               evdw=evdw+(evdwij+e_augm)*sss
13880               if (lprn) then
13881               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13882               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13883               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13884                 restyp(itypi,1),i,restyp(itypj,1),j,&
13885                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13886                 chi1,chi2,chip1,chip2,&
13887                 eps1,eps2rt**2,eps3rt**2,&
13888                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13889                 evdwij+e_augm
13890               endif
13891 ! Calculate gradient components.
13892               e1=e1*eps1*eps2rt**2*eps3rt**2
13893               fac=-expon*(e1+evdwij)*rij_shift
13894               sigder=fac*sigder
13895               fac=rij*fac-2*expon*rrij*e_augm
13896 ! Calculate the radial part of the gradient
13897               gg(1)=xj*fac
13898               gg(2)=yj*fac
13899               gg(3)=zj*fac
13900 ! Calculate angular part of the gradient.
13901               call sc_grad_scale(sss)
13902             endif
13903           enddo      ! j
13904         enddo        ! iint
13905       enddo          ! i
13906       end subroutine egbv_short
13907 !-----------------------------------------------------------------------------
13908       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13909 !
13910 ! This subroutine calculates the average interaction energy and its gradient
13911 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13912 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13913 ! The potential depends both on the distance of peptide-group centers and on
13914 ! the orientation of the CA-CA virtual bonds.
13915 !
13916 !      implicit real*8 (a-h,o-z)
13917
13918       use comm_locel
13919 #ifdef MPI
13920       include 'mpif.h'
13921 #endif
13922 !      include 'DIMENSIONS'
13923 !      include 'COMMON.CONTROL'
13924 !      include 'COMMON.SETUP'
13925 !      include 'COMMON.IOUNITS'
13926 !      include 'COMMON.GEO'
13927 !      include 'COMMON.VAR'
13928 !      include 'COMMON.LOCAL'
13929 !      include 'COMMON.CHAIN'
13930 !      include 'COMMON.DERIV'
13931 !      include 'COMMON.INTERACT'
13932 !      include 'COMMON.CONTACTS'
13933 !      include 'COMMON.TORSION'
13934 !      include 'COMMON.VECTORS'
13935 !      include 'COMMON.FFIELD'
13936 !      include 'COMMON.TIME1'
13937       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13938       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13939       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13940 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13941       real(kind=8),dimension(4) :: muij
13942 !el      integer :: num_conti,j1,j2
13943 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13944 !el                   dz_normi,xmedi,ymedi,zmedi
13945 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13946 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13947 !el          num_conti,j1,j2
13948 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13949 #ifdef MOMENT
13950       real(kind=8) :: scal_el=1.0d0
13951 #else
13952       real(kind=8) :: scal_el=0.5d0
13953 #endif
13954 ! 12/13/98
13955 ! 13-go grudnia roku pamietnego...
13956       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13957                                              0.0d0,1.0d0,0.0d0,&
13958                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13959 !el local variables
13960       integer :: i,j,k
13961       real(kind=8) :: fac
13962       real(kind=8) :: dxj,dyj,dzj
13963       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13964
13965 !      allocate(num_cont_hb(nres)) !(maxres)
13966 !d      write(iout,*) 'In EELEC'
13967 !d      do i=1,nloctyp
13968 !d        write(iout,*) 'Type',i
13969 !d        write(iout,*) 'B1',B1(:,i)
13970 !d        write(iout,*) 'B2',B2(:,i)
13971 !d        write(iout,*) 'CC',CC(:,:,i)
13972 !d        write(iout,*) 'DD',DD(:,:,i)
13973 !d        write(iout,*) 'EE',EE(:,:,i)
13974 !d      enddo
13975 !d      call check_vecgrad
13976 !d      stop
13977       if (icheckgrad.eq.1) then
13978         do i=1,nres-1
13979           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13980           do k=1,3
13981             dc_norm(k,i)=dc(k,i)*fac
13982           enddo
13983 !          write (iout,*) 'i',i,' fac',fac
13984         enddo
13985       endif
13986       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13987           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13988           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13989 !        call vec_and_deriv
13990 #ifdef TIMING
13991         time01=MPI_Wtime()
13992 #endif
13993 !        print *, "before set matrices"
13994         call set_matrices
13995 !        print *,"after set martices"
13996 #ifdef TIMING
13997         time_mat=time_mat+MPI_Wtime()-time01
13998 #endif
13999       endif
14000 !d      do i=1,nres-1
14001 !d        write (iout,*) 'i=',i
14002 !d        do k=1,3
14003 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14004 !d        enddo
14005 !d        do k=1,3
14006 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14007 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14008 !d        enddo
14009 !d      enddo
14010       t_eelecij=0.0d0
14011       ees=0.0D0
14012       evdw1=0.0D0
14013       eel_loc=0.0d0
14014       eello_turn3=0.0d0
14015       eello_turn4=0.0d0
14016 !el      ind=0
14017       do i=1,nres
14018         num_cont_hb(i)=0
14019       enddo
14020 !d      print '(a)','Enter EELEC'
14021 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14022 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14023 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14024       do i=1,nres
14025         gel_loc_loc(i)=0.0d0
14026         gcorr_loc(i)=0.0d0
14027       enddo
14028 !
14029 !
14030 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14031 !
14032 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14033 !
14034       do i=iturn3_start,iturn3_end
14035         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14036         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14037         dxi=dc(1,i)
14038         dyi=dc(2,i)
14039         dzi=dc(3,i)
14040         dx_normi=dc_norm(1,i)
14041         dy_normi=dc_norm(2,i)
14042         dz_normi=dc_norm(3,i)
14043         xmedi=c(1,i)+0.5d0*dxi
14044         ymedi=c(2,i)+0.5d0*dyi
14045         zmedi=c(3,i)+0.5d0*dzi
14046           xmedi=dmod(xmedi,boxxsize)
14047           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14048           ymedi=dmod(ymedi,boxysize)
14049           if (ymedi.lt.0) ymedi=ymedi+boxysize
14050           zmedi=dmod(zmedi,boxzsize)
14051           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14052         num_conti=0
14053         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14054         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14055         num_cont_hb(i)=num_conti
14056       enddo
14057       do i=iturn4_start,iturn4_end
14058         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14059           .or. itype(i+3,1).eq.ntyp1 &
14060           .or. itype(i+4,1).eq.ntyp1) cycle
14061         dxi=dc(1,i)
14062         dyi=dc(2,i)
14063         dzi=dc(3,i)
14064         dx_normi=dc_norm(1,i)
14065         dy_normi=dc_norm(2,i)
14066         dz_normi=dc_norm(3,i)
14067         xmedi=c(1,i)+0.5d0*dxi
14068         ymedi=c(2,i)+0.5d0*dyi
14069         zmedi=c(3,i)+0.5d0*dzi
14070           xmedi=dmod(xmedi,boxxsize)
14071           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14072           ymedi=dmod(ymedi,boxysize)
14073           if (ymedi.lt.0) ymedi=ymedi+boxysize
14074           zmedi=dmod(zmedi,boxzsize)
14075           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14076         num_conti=num_cont_hb(i)
14077         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14078         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14079           call eturn4(i,eello_turn4)
14080         num_cont_hb(i)=num_conti
14081       enddo   ! i
14082 !
14083 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14084 !
14085       do i=iatel_s,iatel_e
14086         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14087         dxi=dc(1,i)
14088         dyi=dc(2,i)
14089         dzi=dc(3,i)
14090         dx_normi=dc_norm(1,i)
14091         dy_normi=dc_norm(2,i)
14092         dz_normi=dc_norm(3,i)
14093         xmedi=c(1,i)+0.5d0*dxi
14094         ymedi=c(2,i)+0.5d0*dyi
14095         zmedi=c(3,i)+0.5d0*dzi
14096           xmedi=dmod(xmedi,boxxsize)
14097           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14098           ymedi=dmod(ymedi,boxysize)
14099           if (ymedi.lt.0) ymedi=ymedi+boxysize
14100           zmedi=dmod(zmedi,boxzsize)
14101           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14102 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14103         num_conti=num_cont_hb(i)
14104         do j=ielstart(i),ielend(i)
14105           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14106           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14107         enddo ! j
14108         num_cont_hb(i)=num_conti
14109       enddo   ! i
14110 !      write (iout,*) "Number of loop steps in EELEC:",ind
14111 !d      do i=1,nres
14112 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14113 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14114 !d      enddo
14115 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14116 !cc      eel_loc=eel_loc+eello_turn3
14117 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14118       return
14119       end subroutine eelec_scale
14120 !-----------------------------------------------------------------------------
14121       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14122 !      implicit real*8 (a-h,o-z)
14123
14124       use comm_locel
14125 !      include 'DIMENSIONS'
14126 #ifdef MPI
14127       include "mpif.h"
14128 #endif
14129 !      include 'COMMON.CONTROL'
14130 !      include 'COMMON.IOUNITS'
14131 !      include 'COMMON.GEO'
14132 !      include 'COMMON.VAR'
14133 !      include 'COMMON.LOCAL'
14134 !      include 'COMMON.CHAIN'
14135 !      include 'COMMON.DERIV'
14136 !      include 'COMMON.INTERACT'
14137 !      include 'COMMON.CONTACTS'
14138 !      include 'COMMON.TORSION'
14139 !      include 'COMMON.VECTORS'
14140 !      include 'COMMON.FFIELD'
14141 !      include 'COMMON.TIME1'
14142       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14143       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14144       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14145 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14146       real(kind=8),dimension(4) :: muij
14147       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14148                     dist_temp, dist_init,sss_grad
14149       integer xshift,yshift,zshift
14150
14151 !el      integer :: num_conti,j1,j2
14152 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14153 !el                   dz_normi,xmedi,ymedi,zmedi
14154 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14155 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14156 !el          num_conti,j1,j2
14157 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14158 #ifdef MOMENT
14159       real(kind=8) :: scal_el=1.0d0
14160 #else
14161       real(kind=8) :: scal_el=0.5d0
14162 #endif
14163 ! 12/13/98
14164 ! 13-go grudnia roku pamietnego...
14165       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14166                                              0.0d0,1.0d0,0.0d0,&
14167                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14168 !el local variables
14169       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14170       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14171       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14172       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14173       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14174       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14175       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14176                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14177                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14178                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14179                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14180                   ecosam,ecosbm,ecosgm,ghalf,time00
14181 !      integer :: maxconts
14182 !      maxconts = nres/4
14183 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14184 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14185 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14186 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14187 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14188 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14189 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14190 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14191 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14192 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14193 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14194 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14195 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14196
14197 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14198 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14199
14200 #ifdef MPI
14201           time00=MPI_Wtime()
14202 #endif
14203 !d      write (iout,*) "eelecij",i,j
14204 !el          ind=ind+1
14205           iteli=itel(i)
14206           itelj=itel(j)
14207           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14208           aaa=app(iteli,itelj)
14209           bbb=bpp(iteli,itelj)
14210           ael6i=ael6(iteli,itelj)
14211           ael3i=ael3(iteli,itelj)
14212           dxj=dc(1,j)
14213           dyj=dc(2,j)
14214           dzj=dc(3,j)
14215           dx_normj=dc_norm(1,j)
14216           dy_normj=dc_norm(2,j)
14217           dz_normj=dc_norm(3,j)
14218 !          xj=c(1,j)+0.5D0*dxj-xmedi
14219 !          yj=c(2,j)+0.5D0*dyj-ymedi
14220 !          zj=c(3,j)+0.5D0*dzj-zmedi
14221           xj=c(1,j)+0.5D0*dxj
14222           yj=c(2,j)+0.5D0*dyj
14223           zj=c(3,j)+0.5D0*dzj
14224           xj=mod(xj,boxxsize)
14225           if (xj.lt.0) xj=xj+boxxsize
14226           yj=mod(yj,boxysize)
14227           if (yj.lt.0) yj=yj+boxysize
14228           zj=mod(zj,boxzsize)
14229           if (zj.lt.0) zj=zj+boxzsize
14230       isubchap=0
14231       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14232       xj_safe=xj
14233       yj_safe=yj
14234       zj_safe=zj
14235       do xshift=-1,1
14236       do yshift=-1,1
14237       do zshift=-1,1
14238           xj=xj_safe+xshift*boxxsize
14239           yj=yj_safe+yshift*boxysize
14240           zj=zj_safe+zshift*boxzsize
14241           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14242           if(dist_temp.lt.dist_init) then
14243             dist_init=dist_temp
14244             xj_temp=xj
14245             yj_temp=yj
14246             zj_temp=zj
14247             isubchap=1
14248           endif
14249        enddo
14250        enddo
14251        enddo
14252        if (isubchap.eq.1) then
14253 !C          print *,i,j
14254           xj=xj_temp-xmedi
14255           yj=yj_temp-ymedi
14256           zj=zj_temp-zmedi
14257        else
14258           xj=xj_safe-xmedi
14259           yj=yj_safe-ymedi
14260           zj=zj_safe-zmedi
14261        endif
14262
14263           rij=xj*xj+yj*yj+zj*zj
14264           rrmij=1.0D0/rij
14265           rij=dsqrt(rij)
14266           rmij=1.0D0/rij
14267 ! For extracting the short-range part of Evdwpp
14268           sss=sscale(rij/rpp(iteli,itelj))
14269             sss_ele_cut=sscale_ele(rij)
14270             sss_ele_grad=sscagrad_ele(rij)
14271             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14272 !             sss_ele_cut=1.0d0
14273 !             sss_ele_grad=0.0d0
14274             if (sss_ele_cut.le.0.0) go to 128
14275
14276           r3ij=rrmij*rmij
14277           r6ij=r3ij*r3ij
14278           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14279           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14280           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14281           fac=cosa-3.0D0*cosb*cosg
14282           ev1=aaa*r6ij*r6ij
14283 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14284           if (j.eq.i+2) ev1=scal_el*ev1
14285           ev2=bbb*r6ij
14286           fac3=ael6i*r6ij
14287           fac4=ael3i*r3ij
14288           evdwij=ev1+ev2
14289           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14290           el2=fac4*fac
14291           eesij=el1+el2
14292 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14293           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14294           ees=ees+eesij*sss_ele_cut
14295           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14296 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14297 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14298 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14299 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14300
14301           if (energy_dec) then
14302               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14303               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14304           endif
14305
14306 !
14307 ! Calculate contributions to the Cartesian gradient.
14308 !
14309 #ifdef SPLITELE
14310           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14311           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14312           fac1=fac
14313           erij(1)=xj*rmij
14314           erij(2)=yj*rmij
14315           erij(3)=zj*rmij
14316 !
14317 ! Radial derivatives. First process both termini of the fragment (i,j)
14318 !
14319           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14320           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14321           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14322 !          do k=1,3
14323 !            ghalf=0.5D0*ggg(k)
14324 !            gelc(k,i)=gelc(k,i)+ghalf
14325 !            gelc(k,j)=gelc(k,j)+ghalf
14326 !          enddo
14327 ! 9/28/08 AL Gradient compotents will be summed only at the end
14328           do k=1,3
14329             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14330             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14331           enddo
14332 !
14333 ! Loop over residues i+1 thru j-1.
14334 !
14335 !grad          do k=i+1,j-1
14336 !grad            do l=1,3
14337 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14338 !grad            enddo
14339 !grad          enddo
14340           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14341           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14342           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14343           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14344           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14345           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14346 !          do k=1,3
14347 !            ghalf=0.5D0*ggg(k)
14348 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14349 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14350 !          enddo
14351 ! 9/28/08 AL Gradient compotents will be summed only at the end
14352           do k=1,3
14353             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14354             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14355           enddo
14356 !
14357 ! Loop over residues i+1 thru j-1.
14358 !
14359 !grad          do k=i+1,j-1
14360 !grad            do l=1,3
14361 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14362 !grad            enddo
14363 !grad          enddo
14364 #else
14365           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14366           facel=(el1+eesij)*sss_ele_cut
14367           fac1=fac
14368           fac=-3*rrmij*(facvdw+facvdw+facel)
14369           erij(1)=xj*rmij
14370           erij(2)=yj*rmij
14371           erij(3)=zj*rmij
14372 !
14373 ! Radial derivatives. First process both termini of the fragment (i,j)
14374 !
14375           ggg(1)=fac*xj
14376           ggg(2)=fac*yj
14377           ggg(3)=fac*zj
14378 !          do k=1,3
14379 !            ghalf=0.5D0*ggg(k)
14380 !            gelc(k,i)=gelc(k,i)+ghalf
14381 !            gelc(k,j)=gelc(k,j)+ghalf
14382 !          enddo
14383 ! 9/28/08 AL Gradient compotents will be summed only at the end
14384           do k=1,3
14385             gelc_long(k,j)=gelc(k,j)+ggg(k)
14386             gelc_long(k,i)=gelc(k,i)-ggg(k)
14387           enddo
14388 !
14389 ! Loop over residues i+1 thru j-1.
14390 !
14391 !grad          do k=i+1,j-1
14392 !grad            do l=1,3
14393 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14394 !grad            enddo
14395 !grad          enddo
14396 ! 9/28/08 AL Gradient compotents will be summed only at the end
14397           ggg(1)=facvdw*xj
14398           ggg(2)=facvdw*yj
14399           ggg(3)=facvdw*zj
14400           do k=1,3
14401             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14402             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14403           enddo
14404 #endif
14405 !
14406 ! Angular part
14407 !
14408           ecosa=2.0D0*fac3*fac1+fac4
14409           fac4=-3.0D0*fac4
14410           fac3=-6.0D0*fac3
14411           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14412           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14413           do k=1,3
14414             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14415             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14416           enddo
14417 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14418 !d   &          (dcosg(k),k=1,3)
14419           do k=1,3
14420             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14421           enddo
14422 !          do k=1,3
14423 !            ghalf=0.5D0*ggg(k)
14424 !            gelc(k,i)=gelc(k,i)+ghalf
14425 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14426 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14427 !            gelc(k,j)=gelc(k,j)+ghalf
14428 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14429 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14430 !          enddo
14431 !grad          do k=i+1,j-1
14432 !grad            do l=1,3
14433 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14434 !grad            enddo
14435 !grad          enddo
14436           do k=1,3
14437             gelc(k,i)=gelc(k,i) &
14438                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14439                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14440                      *sss_ele_cut
14441             gelc(k,j)=gelc(k,j) &
14442                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14443                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14444                      *sss_ele_cut
14445             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14446             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14447           enddo
14448           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14449               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14450               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14451 !
14452 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14453 !   energy of a peptide unit is assumed in the form of a second-order
14454 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14455 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14456 !   are computed for EVERY pair of non-contiguous peptide groups.
14457 !
14458           if (j.lt.nres-1) then
14459             j1=j+1
14460             j2=j-1
14461           else
14462             j1=j-1
14463             j2=j-2
14464           endif
14465           kkk=0
14466           do k=1,2
14467             do l=1,2
14468               kkk=kkk+1
14469               muij(kkk)=mu(k,i)*mu(l,j)
14470             enddo
14471           enddo
14472 !d         write (iout,*) 'EELEC: i',i,' j',j
14473 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14474 !d          write(iout,*) 'muij',muij
14475           ury=scalar(uy(1,i),erij)
14476           urz=scalar(uz(1,i),erij)
14477           vry=scalar(uy(1,j),erij)
14478           vrz=scalar(uz(1,j),erij)
14479           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14480           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14481           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14482           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14483           fac=dsqrt(-ael6i)*r3ij
14484           a22=a22*fac
14485           a23=a23*fac
14486           a32=a32*fac
14487           a33=a33*fac
14488 !d          write (iout,'(4i5,4f10.5)')
14489 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14490 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14491 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14492 !d     &      uy(:,j),uz(:,j)
14493 !d          write (iout,'(4f10.5)')
14494 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14495 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14496 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14497 !d           write (iout,'(9f10.5/)')
14498 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14499 ! Derivatives of the elements of A in virtual-bond vectors
14500           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14501           do k=1,3
14502             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14503             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14504             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14505             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14506             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14507             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14508             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14509             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14510             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14511             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14512             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14513             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14514           enddo
14515 ! Compute radial contributions to the gradient
14516           facr=-3.0d0*rrmij
14517           a22der=a22*facr
14518           a23der=a23*facr
14519           a32der=a32*facr
14520           a33der=a33*facr
14521           agg(1,1)=a22der*xj
14522           agg(2,1)=a22der*yj
14523           agg(3,1)=a22der*zj
14524           agg(1,2)=a23der*xj
14525           agg(2,2)=a23der*yj
14526           agg(3,2)=a23der*zj
14527           agg(1,3)=a32der*xj
14528           agg(2,3)=a32der*yj
14529           agg(3,3)=a32der*zj
14530           agg(1,4)=a33der*xj
14531           agg(2,4)=a33der*yj
14532           agg(3,4)=a33der*zj
14533 ! Add the contributions coming from er
14534           fac3=-3.0d0*fac
14535           do k=1,3
14536             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14537             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14538             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14539             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14540           enddo
14541           do k=1,3
14542 ! Derivatives in DC(i)
14543 !grad            ghalf1=0.5d0*agg(k,1)
14544 !grad            ghalf2=0.5d0*agg(k,2)
14545 !grad            ghalf3=0.5d0*agg(k,3)
14546 !grad            ghalf4=0.5d0*agg(k,4)
14547             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14548             -3.0d0*uryg(k,2)*vry)!+ghalf1
14549             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14550             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14551             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14552             -3.0d0*urzg(k,2)*vry)!+ghalf3
14553             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14554             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14555 ! Derivatives in DC(i+1)
14556             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14557             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14558             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14559             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14560             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14561             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14562             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14563             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14564 ! Derivatives in DC(j)
14565             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14566             -3.0d0*vryg(k,2)*ury)!+ghalf1
14567             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14568             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14569             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14570             -3.0d0*vryg(k,2)*urz)!+ghalf3
14571             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14572             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14573 ! Derivatives in DC(j+1) or DC(nres-1)
14574             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14575             -3.0d0*vryg(k,3)*ury)
14576             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14577             -3.0d0*vrzg(k,3)*ury)
14578             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14579             -3.0d0*vryg(k,3)*urz)
14580             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14581             -3.0d0*vrzg(k,3)*urz)
14582 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14583 !grad              do l=1,4
14584 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14585 !grad              enddo
14586 !grad            endif
14587           enddo
14588           acipa(1,1)=a22
14589           acipa(1,2)=a23
14590           acipa(2,1)=a32
14591           acipa(2,2)=a33
14592           a22=-a22
14593           a23=-a23
14594           do l=1,2
14595             do k=1,3
14596               agg(k,l)=-agg(k,l)
14597               aggi(k,l)=-aggi(k,l)
14598               aggi1(k,l)=-aggi1(k,l)
14599               aggj(k,l)=-aggj(k,l)
14600               aggj1(k,l)=-aggj1(k,l)
14601             enddo
14602           enddo
14603           if (j.lt.nres-1) then
14604             a22=-a22
14605             a32=-a32
14606             do l=1,3,2
14607               do k=1,3
14608                 agg(k,l)=-agg(k,l)
14609                 aggi(k,l)=-aggi(k,l)
14610                 aggi1(k,l)=-aggi1(k,l)
14611                 aggj(k,l)=-aggj(k,l)
14612                 aggj1(k,l)=-aggj1(k,l)
14613               enddo
14614             enddo
14615           else
14616             a22=-a22
14617             a23=-a23
14618             a32=-a32
14619             a33=-a33
14620             do l=1,4
14621               do k=1,3
14622                 agg(k,l)=-agg(k,l)
14623                 aggi(k,l)=-aggi(k,l)
14624                 aggi1(k,l)=-aggi1(k,l)
14625                 aggj(k,l)=-aggj(k,l)
14626                 aggj1(k,l)=-aggj1(k,l)
14627               enddo
14628             enddo
14629           endif
14630           ENDIF ! WCORR
14631           IF (wel_loc.gt.0.0d0) THEN
14632 ! Contribution to the local-electrostatic energy coming from the i-j pair
14633           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14634            +a33*muij(4)
14635 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14636 !           print *,"EELLOC",i,gel_loc_loc(i-1)
14637           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14638                   'eelloc',i,j,eel_loc_ij
14639 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14640
14641           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14642 ! Partial derivatives in virtual-bond dihedral angles gamma
14643           if (i.gt.1) &
14644           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14645                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14646                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14647                  *sss_ele_cut
14648           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14649                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14650                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14651                  *sss_ele_cut
14652            xtemp(1)=xj
14653            xtemp(2)=yj
14654            xtemp(3)=zj
14655
14656 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14657           do l=1,3
14658             ggg(l)=(agg(l,1)*muij(1)+ &
14659                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14660             *sss_ele_cut &
14661              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14662
14663             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14664             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14665 !grad            ghalf=0.5d0*ggg(l)
14666 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14667 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14668           enddo
14669 !grad          do k=i+1,j2
14670 !grad            do l=1,3
14671 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14672 !grad            enddo
14673 !grad          enddo
14674 ! Remaining derivatives of eello
14675           do l=1,3
14676             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14677                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14678             *sss_ele_cut
14679
14680             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14681                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14682             *sss_ele_cut
14683
14684             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14685                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14686             *sss_ele_cut
14687
14688             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14689                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14690             *sss_ele_cut
14691
14692           enddo
14693           ENDIF
14694 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14695 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14696           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14697              .and. num_conti.le.maxconts) then
14698 !            write (iout,*) i,j," entered corr"
14699 !
14700 ! Calculate the contact function. The ith column of the array JCONT will
14701 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14702 ! greater than I). The arrays FACONT and GACONT will contain the values of
14703 ! the contact function and its derivative.
14704 !           r0ij=1.02D0*rpp(iteli,itelj)
14705 !           r0ij=1.11D0*rpp(iteli,itelj)
14706             r0ij=2.20D0*rpp(iteli,itelj)
14707 !           r0ij=1.55D0*rpp(iteli,itelj)
14708             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14709 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14710             if (fcont.gt.0.0D0) then
14711               num_conti=num_conti+1
14712               if (num_conti.gt.maxconts) then
14713 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14714                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14715                                ' will skip next contacts for this conf.',num_conti
14716               else
14717                 jcont_hb(num_conti,i)=j
14718 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14719 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14720                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14721                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14722 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14723 !  terms.
14724                 d_cont(num_conti,i)=rij
14725 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14726 !     --- Electrostatic-interaction matrix ---
14727                 a_chuj(1,1,num_conti,i)=a22
14728                 a_chuj(1,2,num_conti,i)=a23
14729                 a_chuj(2,1,num_conti,i)=a32
14730                 a_chuj(2,2,num_conti,i)=a33
14731 !     --- Gradient of rij
14732                 do kkk=1,3
14733                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14734                 enddo
14735                 kkll=0
14736                 do k=1,2
14737                   do l=1,2
14738                     kkll=kkll+1
14739                     do m=1,3
14740                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14741                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14742                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14743                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14744                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14745                     enddo
14746                   enddo
14747                 enddo
14748                 ENDIF
14749                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14750 ! Calculate contact energies
14751                 cosa4=4.0D0*cosa
14752                 wij=cosa-3.0D0*cosb*cosg
14753                 cosbg1=cosb+cosg
14754                 cosbg2=cosb-cosg
14755 !               fac3=dsqrt(-ael6i)/r0ij**3
14756                 fac3=dsqrt(-ael6i)*r3ij
14757 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14758                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14759                 if (ees0tmp.gt.0) then
14760                   ees0pij=dsqrt(ees0tmp)
14761                 else
14762                   ees0pij=0
14763                 endif
14764 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14765                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14766                 if (ees0tmp.gt.0) then
14767                   ees0mij=dsqrt(ees0tmp)
14768                 else
14769                   ees0mij=0
14770                 endif
14771 !               ees0mij=0.0D0
14772                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14773                      *sss_ele_cut
14774
14775                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14776                      *sss_ele_cut
14777
14778 ! Diagnostics. Comment out or remove after debugging!
14779 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14780 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14781 !               ees0m(num_conti,i)=0.0D0
14782 ! End diagnostics.
14783 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14784 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14785 ! Angular derivatives of the contact function
14786                 ees0pij1=fac3/ees0pij
14787                 ees0mij1=fac3/ees0mij
14788                 fac3p=-3.0D0*fac3*rrmij
14789                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14790                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14791 !               ees0mij1=0.0D0
14792                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14793                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14794                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14795                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14796                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14797                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14798                 ecosap=ecosa1+ecosa2
14799                 ecosbp=ecosb1+ecosb2
14800                 ecosgp=ecosg1+ecosg2
14801                 ecosam=ecosa1-ecosa2
14802                 ecosbm=ecosb1-ecosb2
14803                 ecosgm=ecosg1-ecosg2
14804 ! Diagnostics
14805 !               ecosap=ecosa1
14806 !               ecosbp=ecosb1
14807 !               ecosgp=ecosg1
14808 !               ecosam=0.0D0
14809 !               ecosbm=0.0D0
14810 !               ecosgm=0.0D0
14811 ! End diagnostics
14812                 facont_hb(num_conti,i)=fcont
14813                 fprimcont=fprimcont/rij
14814 !d              facont_hb(num_conti,i)=1.0D0
14815 ! Following line is for diagnostics.
14816 !d              fprimcont=0.0D0
14817                 do k=1,3
14818                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14819                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14820                 enddo
14821                 do k=1,3
14822                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14823                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14824                 enddo
14825 !                gggp(1)=gggp(1)+ees0pijp*xj
14826 !                gggp(2)=gggp(2)+ees0pijp*yj
14827 !                gggp(3)=gggp(3)+ees0pijp*zj
14828 !                gggm(1)=gggm(1)+ees0mijp*xj
14829 !                gggm(2)=gggm(2)+ees0mijp*yj
14830 !                gggm(3)=gggm(3)+ees0mijp*zj
14831                 gggp(1)=gggp(1)+ees0pijp*xj &
14832                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14833                 gggp(2)=gggp(2)+ees0pijp*yj &
14834                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14835                 gggp(3)=gggp(3)+ees0pijp*zj &
14836                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14837
14838                 gggm(1)=gggm(1)+ees0mijp*xj &
14839                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14840
14841                 gggm(2)=gggm(2)+ees0mijp*yj &
14842                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14843
14844                 gggm(3)=gggm(3)+ees0mijp*zj &
14845                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14846
14847 ! Derivatives due to the contact function
14848                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14849                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14850                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14851                 do k=1,3
14852 !
14853 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14854 !          following the change of gradient-summation algorithm.
14855 !
14856 !grad                  ghalfp=0.5D0*gggp(k)
14857 !grad                  ghalfm=0.5D0*gggm(k)
14858 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14859 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14860 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14861 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14862 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14863 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14864 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14865 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14866 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14867 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14868 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14869 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14870 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14871 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14872                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14873                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14874                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14875                      *sss_ele_cut
14876
14877                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14878                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14879                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14880                      *sss_ele_cut
14881
14882                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14883                      *sss_ele_cut
14884
14885                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14886                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14887                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14888                      *sss_ele_cut
14889
14890                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14891                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14892                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14893                      *sss_ele_cut
14894
14895                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14896                      *sss_ele_cut
14897
14898                 enddo
14899               ENDIF ! wcorr
14900               endif  ! num_conti.le.maxconts
14901             endif  ! fcont.gt.0
14902           endif    ! j.gt.i+1
14903           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14904             do k=1,4
14905               do l=1,3
14906                 ghalf=0.5d0*agg(l,k)
14907                 aggi(l,k)=aggi(l,k)+ghalf
14908                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14909                 aggj(l,k)=aggj(l,k)+ghalf
14910               enddo
14911             enddo
14912             if (j.eq.nres-1 .and. i.lt.j-2) then
14913               do k=1,4
14914                 do l=1,3
14915                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14916                 enddo
14917               enddo
14918             endif
14919           endif
14920  128      continue
14921 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14922       return
14923       end subroutine eelecij_scale
14924 !-----------------------------------------------------------------------------
14925       subroutine evdwpp_short(evdw1)
14926 !
14927 ! Compute Evdwpp
14928 !
14929 !      implicit real*8 (a-h,o-z)
14930 !      include 'DIMENSIONS'
14931 !      include 'COMMON.CONTROL'
14932 !      include 'COMMON.IOUNITS'
14933 !      include 'COMMON.GEO'
14934 !      include 'COMMON.VAR'
14935 !      include 'COMMON.LOCAL'
14936 !      include 'COMMON.CHAIN'
14937 !      include 'COMMON.DERIV'
14938 !      include 'COMMON.INTERACT'
14939 !      include 'COMMON.CONTACTS'
14940 !      include 'COMMON.TORSION'
14941 !      include 'COMMON.VECTORS'
14942 !      include 'COMMON.FFIELD'
14943       real(kind=8),dimension(3) :: ggg
14944 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14945 #ifdef MOMENT
14946       real(kind=8) :: scal_el=1.0d0
14947 #else
14948       real(kind=8) :: scal_el=0.5d0
14949 #endif
14950 !el local variables
14951       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14952       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14953       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14954                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14955                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14956       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14957                     dist_temp, dist_init,sss_grad
14958       integer xshift,yshift,zshift
14959
14960
14961       evdw1=0.0D0
14962 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14963 !     & " iatel_e_vdw",iatel_e_vdw
14964       call flush(iout)
14965       do i=iatel_s_vdw,iatel_e_vdw
14966         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14967         dxi=dc(1,i)
14968         dyi=dc(2,i)
14969         dzi=dc(3,i)
14970         dx_normi=dc_norm(1,i)
14971         dy_normi=dc_norm(2,i)
14972         dz_normi=dc_norm(3,i)
14973         xmedi=c(1,i)+0.5d0*dxi
14974         ymedi=c(2,i)+0.5d0*dyi
14975         zmedi=c(3,i)+0.5d0*dzi
14976           xmedi=dmod(xmedi,boxxsize)
14977           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14978           ymedi=dmod(ymedi,boxysize)
14979           if (ymedi.lt.0) ymedi=ymedi+boxysize
14980           zmedi=dmod(zmedi,boxzsize)
14981           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14982         num_conti=0
14983 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14984 !     &   ' ielend',ielend_vdw(i)
14985         call flush(iout)
14986         do j=ielstart_vdw(i),ielend_vdw(i)
14987           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14988 !el          ind=ind+1
14989           iteli=itel(i)
14990           itelj=itel(j)
14991           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14992           aaa=app(iteli,itelj)
14993           bbb=bpp(iteli,itelj)
14994           dxj=dc(1,j)
14995           dyj=dc(2,j)
14996           dzj=dc(3,j)
14997           dx_normj=dc_norm(1,j)
14998           dy_normj=dc_norm(2,j)
14999           dz_normj=dc_norm(3,j)
15000 !          xj=c(1,j)+0.5D0*dxj-xmedi
15001 !          yj=c(2,j)+0.5D0*dyj-ymedi
15002 !          zj=c(3,j)+0.5D0*dzj-zmedi
15003           xj=c(1,j)+0.5D0*dxj
15004           yj=c(2,j)+0.5D0*dyj
15005           zj=c(3,j)+0.5D0*dzj
15006           xj=mod(xj,boxxsize)
15007           if (xj.lt.0) xj=xj+boxxsize
15008           yj=mod(yj,boxysize)
15009           if (yj.lt.0) yj=yj+boxysize
15010           zj=mod(zj,boxzsize)
15011           if (zj.lt.0) zj=zj+boxzsize
15012       isubchap=0
15013       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15014       xj_safe=xj
15015       yj_safe=yj
15016       zj_safe=zj
15017       do xshift=-1,1
15018       do yshift=-1,1
15019       do zshift=-1,1
15020           xj=xj_safe+xshift*boxxsize
15021           yj=yj_safe+yshift*boxysize
15022           zj=zj_safe+zshift*boxzsize
15023           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15024           if(dist_temp.lt.dist_init) then
15025             dist_init=dist_temp
15026             xj_temp=xj
15027             yj_temp=yj
15028             zj_temp=zj
15029             isubchap=1
15030           endif
15031        enddo
15032        enddo
15033        enddo
15034        if (isubchap.eq.1) then
15035 !C          print *,i,j
15036           xj=xj_temp-xmedi
15037           yj=yj_temp-ymedi
15038           zj=zj_temp-zmedi
15039        else
15040           xj=xj_safe-xmedi
15041           yj=yj_safe-ymedi
15042           zj=zj_safe-zmedi
15043        endif
15044
15045           rij=xj*xj+yj*yj+zj*zj
15046           rrmij=1.0D0/rij
15047           rij=dsqrt(rij)
15048           sss=sscale(rij/rpp(iteli,itelj))
15049             sss_ele_cut=sscale_ele(rij)
15050             sss_ele_grad=sscagrad_ele(rij)
15051             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15052             if (sss_ele_cut.le.0.0) cycle
15053           if (sss.gt.0.0d0) then
15054             rmij=1.0D0/rij
15055             r3ij=rrmij*rmij
15056             r6ij=r3ij*r3ij
15057             ev1=aaa*r6ij*r6ij
15058 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15059             if (j.eq.i+2) ev1=scal_el*ev1
15060             ev2=bbb*r6ij
15061             evdwij=ev1+ev2
15062             if (energy_dec) then
15063               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15064             endif
15065             evdw1=evdw1+evdwij*sss*sss_ele_cut
15066 !
15067 ! Calculate contributions to the Cartesian gradient.
15068 !
15069             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15070 !            ggg(1)=facvdw*xj
15071 !            ggg(2)=facvdw*yj
15072 !            ggg(3)=facvdw*zj
15073           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15074           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15075           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15076           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15077           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15078           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15079
15080             do k=1,3
15081               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15082               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15083             enddo
15084           endif
15085         enddo ! j
15086       enddo   ! i
15087       return
15088       end subroutine evdwpp_short
15089 !-----------------------------------------------------------------------------
15090       subroutine escp_long(evdw2,evdw2_14)
15091 !
15092 ! This subroutine calculates the excluded-volume interaction energy between
15093 ! peptide-group centers and side chains and its gradient in virtual-bond and
15094 ! side-chain vectors.
15095 !
15096 !      implicit real*8 (a-h,o-z)
15097 !      include 'DIMENSIONS'
15098 !      include 'COMMON.GEO'
15099 !      include 'COMMON.VAR'
15100 !      include 'COMMON.LOCAL'
15101 !      include 'COMMON.CHAIN'
15102 !      include 'COMMON.DERIV'
15103 !      include 'COMMON.INTERACT'
15104 !      include 'COMMON.FFIELD'
15105 !      include 'COMMON.IOUNITS'
15106 !      include 'COMMON.CONTROL'
15107       real(kind=8),dimension(3) :: ggg
15108 !el local variables
15109       integer :: i,iint,j,k,iteli,itypj,subchap
15110       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15111       real(kind=8) :: evdw2,evdw2_14,evdwij
15112       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15113                     dist_temp, dist_init
15114
15115       evdw2=0.0D0
15116       evdw2_14=0.0d0
15117 !d    print '(a)','Enter ESCP'
15118 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15119       do i=iatscp_s,iatscp_e
15120         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15121         iteli=itel(i)
15122         xi=0.5D0*(c(1,i)+c(1,i+1))
15123         yi=0.5D0*(c(2,i)+c(2,i+1))
15124         zi=0.5D0*(c(3,i)+c(3,i+1))
15125           xi=mod(xi,boxxsize)
15126           if (xi.lt.0) xi=xi+boxxsize
15127           yi=mod(yi,boxysize)
15128           if (yi.lt.0) yi=yi+boxysize
15129           zi=mod(zi,boxzsize)
15130           if (zi.lt.0) zi=zi+boxzsize
15131
15132         do iint=1,nscp_gr(i)
15133
15134         do j=iscpstart(i,iint),iscpend(i,iint)
15135           itypj=itype(j,1)
15136           if (itypj.eq.ntyp1) cycle
15137 ! Uncomment following three lines for SC-p interactions
15138 !         xj=c(1,nres+j)-xi
15139 !         yj=c(2,nres+j)-yi
15140 !         zj=c(3,nres+j)-zi
15141 ! Uncomment following three lines for Ca-p interactions
15142           xj=c(1,j)
15143           yj=c(2,j)
15144           zj=c(3,j)
15145           xj=mod(xj,boxxsize)
15146           if (xj.lt.0) xj=xj+boxxsize
15147           yj=mod(yj,boxysize)
15148           if (yj.lt.0) yj=yj+boxysize
15149           zj=mod(zj,boxzsize)
15150           if (zj.lt.0) zj=zj+boxzsize
15151       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15152       xj_safe=xj
15153       yj_safe=yj
15154       zj_safe=zj
15155       subchap=0
15156       do xshift=-1,1
15157       do yshift=-1,1
15158       do zshift=-1,1
15159           xj=xj_safe+xshift*boxxsize
15160           yj=yj_safe+yshift*boxysize
15161           zj=zj_safe+zshift*boxzsize
15162           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15163           if(dist_temp.lt.dist_init) then
15164             dist_init=dist_temp
15165             xj_temp=xj
15166             yj_temp=yj
15167             zj_temp=zj
15168             subchap=1
15169           endif
15170        enddo
15171        enddo
15172        enddo
15173        if (subchap.eq.1) then
15174           xj=xj_temp-xi
15175           yj=yj_temp-yi
15176           zj=zj_temp-zi
15177        else
15178           xj=xj_safe-xi
15179           yj=yj_safe-yi
15180           zj=zj_safe-zi
15181        endif
15182           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15183
15184           rij=dsqrt(1.0d0/rrij)
15185             sss_ele_cut=sscale_ele(rij)
15186             sss_ele_grad=sscagrad_ele(rij)
15187 !            print *,sss_ele_cut,sss_ele_grad,&
15188 !            (rij),r_cut_ele,rlamb_ele
15189             if (sss_ele_cut.le.0.0) cycle
15190           sss=sscale((rij/rscp(itypj,iteli)))
15191           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15192           if (sss.lt.1.0d0) then
15193
15194             fac=rrij**expon2
15195             e1=fac*fac*aad(itypj,iteli)
15196             e2=fac*bad(itypj,iteli)
15197             if (iabs(j-i) .le. 2) then
15198               e1=scal14*e1
15199               e2=scal14*e2
15200               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15201             endif
15202             evdwij=e1+e2
15203             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15204             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15205                 'evdw2',i,j,sss,evdwij
15206 !
15207 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15208 !
15209             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15210             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15211             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15212             ggg(1)=xj*fac
15213             ggg(2)=yj*fac
15214             ggg(3)=zj*fac
15215 ! Uncomment following three lines for SC-p interactions
15216 !           do k=1,3
15217 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15218 !           enddo
15219 ! Uncomment following line for SC-p interactions
15220 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15221             do k=1,3
15222               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15223               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15224             enddo
15225           endif
15226         enddo
15227
15228         enddo ! iint
15229       enddo ! i
15230       do i=1,nct
15231         do j=1,3
15232           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15233           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15234           gradx_scp(j,i)=expon*gradx_scp(j,i)
15235         enddo
15236       enddo
15237 !******************************************************************************
15238 !
15239 !                              N O T E !!!
15240 !
15241 ! To save time the factor EXPON has been extracted from ALL components
15242 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15243 ! use!
15244 !
15245 !******************************************************************************
15246       return
15247       end subroutine escp_long
15248 !-----------------------------------------------------------------------------
15249       subroutine escp_short(evdw2,evdw2_14)
15250 !
15251 ! This subroutine calculates the excluded-volume interaction energy between
15252 ! peptide-group centers and side chains and its gradient in virtual-bond and
15253 ! side-chain vectors.
15254 !
15255 !      implicit real*8 (a-h,o-z)
15256 !      include 'DIMENSIONS'
15257 !      include 'COMMON.GEO'
15258 !      include 'COMMON.VAR'
15259 !      include 'COMMON.LOCAL'
15260 !      include 'COMMON.CHAIN'
15261 !      include 'COMMON.DERIV'
15262 !      include 'COMMON.INTERACT'
15263 !      include 'COMMON.FFIELD'
15264 !      include 'COMMON.IOUNITS'
15265 !      include 'COMMON.CONTROL'
15266       real(kind=8),dimension(3) :: ggg
15267 !el local variables
15268       integer :: i,iint,j,k,iteli,itypj,subchap
15269       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15270       real(kind=8) :: evdw2,evdw2_14,evdwij
15271       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15272                     dist_temp, dist_init
15273
15274       evdw2=0.0D0
15275       evdw2_14=0.0d0
15276 !d    print '(a)','Enter ESCP'
15277 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15278       do i=iatscp_s,iatscp_e
15279         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15280         iteli=itel(i)
15281         xi=0.5D0*(c(1,i)+c(1,i+1))
15282         yi=0.5D0*(c(2,i)+c(2,i+1))
15283         zi=0.5D0*(c(3,i)+c(3,i+1))
15284           xi=mod(xi,boxxsize)
15285           if (xi.lt.0) xi=xi+boxxsize
15286           yi=mod(yi,boxysize)
15287           if (yi.lt.0) yi=yi+boxysize
15288           zi=mod(zi,boxzsize)
15289           if (zi.lt.0) zi=zi+boxzsize
15290
15291         do iint=1,nscp_gr(i)
15292
15293         do j=iscpstart(i,iint),iscpend(i,iint)
15294           itypj=itype(j,1)
15295           if (itypj.eq.ntyp1) cycle
15296 ! Uncomment following three lines for SC-p interactions
15297 !         xj=c(1,nres+j)-xi
15298 !         yj=c(2,nres+j)-yi
15299 !         zj=c(3,nres+j)-zi
15300 ! Uncomment following three lines for Ca-p interactions
15301 !          xj=c(1,j)-xi
15302 !          yj=c(2,j)-yi
15303 !          zj=c(3,j)-zi
15304           xj=c(1,j)
15305           yj=c(2,j)
15306           zj=c(3,j)
15307           xj=mod(xj,boxxsize)
15308           if (xj.lt.0) xj=xj+boxxsize
15309           yj=mod(yj,boxysize)
15310           if (yj.lt.0) yj=yj+boxysize
15311           zj=mod(zj,boxzsize)
15312           if (zj.lt.0) zj=zj+boxzsize
15313       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15314       xj_safe=xj
15315       yj_safe=yj
15316       zj_safe=zj
15317       subchap=0
15318       do xshift=-1,1
15319       do yshift=-1,1
15320       do zshift=-1,1
15321           xj=xj_safe+xshift*boxxsize
15322           yj=yj_safe+yshift*boxysize
15323           zj=zj_safe+zshift*boxzsize
15324           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15325           if(dist_temp.lt.dist_init) then
15326             dist_init=dist_temp
15327             xj_temp=xj
15328             yj_temp=yj
15329             zj_temp=zj
15330             subchap=1
15331           endif
15332        enddo
15333        enddo
15334        enddo
15335        if (subchap.eq.1) then
15336           xj=xj_temp-xi
15337           yj=yj_temp-yi
15338           zj=zj_temp-zi
15339        else
15340           xj=xj_safe-xi
15341           yj=yj_safe-yi
15342           zj=zj_safe-zi
15343        endif
15344
15345           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15346           rij=dsqrt(1.0d0/rrij)
15347             sss_ele_cut=sscale_ele(rij)
15348             sss_ele_grad=sscagrad_ele(rij)
15349 !            print *,sss_ele_cut,sss_ele_grad,&
15350 !            (rij),r_cut_ele,rlamb_ele
15351             if (sss_ele_cut.le.0.0) cycle
15352           sss=sscale(rij/rscp(itypj,iteli))
15353           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15354           if (sss.gt.0.0d0) then
15355
15356             fac=rrij**expon2
15357             e1=fac*fac*aad(itypj,iteli)
15358             e2=fac*bad(itypj,iteli)
15359             if (iabs(j-i) .le. 2) then
15360               e1=scal14*e1
15361               e2=scal14*e2
15362               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15363             endif
15364             evdwij=e1+e2
15365             evdw2=evdw2+evdwij*sss*sss_ele_cut
15366             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15367                 'evdw2',i,j,sss,evdwij
15368 !
15369 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15370 !
15371             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15372             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15373             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15374
15375             ggg(1)=xj*fac
15376             ggg(2)=yj*fac
15377             ggg(3)=zj*fac
15378 ! Uncomment following three lines for SC-p interactions
15379 !           do k=1,3
15380 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15381 !           enddo
15382 ! Uncomment following line for SC-p interactions
15383 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15384             do k=1,3
15385               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15386               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15387             enddo
15388           endif
15389         enddo
15390
15391         enddo ! iint
15392       enddo ! i
15393       do i=1,nct
15394         do j=1,3
15395           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15396           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15397           gradx_scp(j,i)=expon*gradx_scp(j,i)
15398         enddo
15399       enddo
15400 !******************************************************************************
15401 !
15402 !                              N O T E !!!
15403 !
15404 ! To save time the factor EXPON has been extracted from ALL components
15405 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15406 ! use!
15407 !
15408 !******************************************************************************
15409       return
15410       end subroutine escp_short
15411 !-----------------------------------------------------------------------------
15412 ! energy_p_new-sep_barrier.F
15413 !-----------------------------------------------------------------------------
15414       subroutine sc_grad_scale(scalfac)
15415 !      implicit real*8 (a-h,o-z)
15416       use calc_data
15417 !      include 'DIMENSIONS'
15418 !      include 'COMMON.CHAIN'
15419 !      include 'COMMON.DERIV'
15420 !      include 'COMMON.CALC'
15421 !      include 'COMMON.IOUNITS'
15422       real(kind=8),dimension(3) :: dcosom1,dcosom2
15423       real(kind=8) :: scalfac
15424 !el local variables
15425 !      integer :: i,j,k,l
15426
15427       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15428       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15429       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15430            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15431 ! diagnostics only
15432 !      eom1=0.0d0
15433 !      eom2=0.0d0
15434 !      eom12=evdwij*eps1_om12
15435 ! end diagnostics
15436 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15437 !     &  " sigder",sigder
15438 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15439 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15440       do k=1,3
15441         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15442         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15443       enddo
15444       do k=1,3
15445         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15446          *sss_ele_cut
15447       enddo
15448 !      write (iout,*) "gg",(gg(k),k=1,3)
15449       do k=1,3
15450         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15451                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15452                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15453                  *sss_ele_cut
15454         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15455                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15456                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15457          *sss_ele_cut
15458 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15459 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15460 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15461 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15462       enddo
15463 !
15464 ! Calculate the components of the gradient in DC and X
15465 !
15466       do l=1,3
15467         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15468         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15469       enddo
15470       return
15471       end subroutine sc_grad_scale
15472 !-----------------------------------------------------------------------------
15473 ! energy_split-sep.F
15474 !-----------------------------------------------------------------------------
15475       subroutine etotal_long(energia)
15476 !
15477 ! Compute the long-range slow-varying contributions to the energy
15478 !
15479 !      implicit real*8 (a-h,o-z)
15480 !      include 'DIMENSIONS'
15481       use MD_data, only: totT,usampl,eq_time
15482 #ifndef ISNAN
15483       external proc_proc
15484 #ifdef WINPGI
15485 !MS$ATTRIBUTES C ::  proc_proc
15486 #endif
15487 #endif
15488 #ifdef MPI
15489       include "mpif.h"
15490       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15491 #endif
15492 !      include 'COMMON.SETUP'
15493 !      include 'COMMON.IOUNITS'
15494 !      include 'COMMON.FFIELD'
15495 !      include 'COMMON.DERIV'
15496 !      include 'COMMON.INTERACT'
15497 !      include 'COMMON.SBRIDGE'
15498 !      include 'COMMON.CHAIN'
15499 !      include 'COMMON.VAR'
15500 !      include 'COMMON.LOCAL'
15501 !      include 'COMMON.MD'
15502       real(kind=8),dimension(0:n_ene) :: energia
15503 !el local variables
15504       integer :: i,n_corr,n_corr1,ierror,ierr
15505       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15506                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15507                   ecorr,ecorr5,ecorr6,eturn6,time00
15508 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15509 !elwrite(iout,*)"in etotal long"
15510
15511       if (modecalc.eq.12.or.modecalc.eq.14) then
15512 #ifdef MPI
15513 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15514 #else
15515         call int_from_cart1(.false.)
15516 #endif
15517       endif
15518 !elwrite(iout,*)"in etotal long"
15519
15520 #ifdef MPI
15521 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15522 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15523       call flush(iout)
15524       if (nfgtasks.gt.1) then
15525         time00=MPI_Wtime()
15526 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15527         if (fg_rank.eq.0) then
15528           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15529 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15530 !          call flush(iout)
15531 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15532 ! FG slaves as WEIGHTS array.
15533           weights_(1)=wsc
15534           weights_(2)=wscp
15535           weights_(3)=welec
15536           weights_(4)=wcorr
15537           weights_(5)=wcorr5
15538           weights_(6)=wcorr6
15539           weights_(7)=wel_loc
15540           weights_(8)=wturn3
15541           weights_(9)=wturn4
15542           weights_(10)=wturn6
15543           weights_(11)=wang
15544           weights_(12)=wscloc
15545           weights_(13)=wtor
15546           weights_(14)=wtor_d
15547           weights_(15)=wstrain
15548           weights_(16)=wvdwpp
15549           weights_(17)=wbond
15550           weights_(18)=scal14
15551           weights_(21)=wsccor
15552 ! FG Master broadcasts the WEIGHTS_ array
15553           call MPI_Bcast(weights_(1),n_ene,&
15554               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15555         else
15556 ! FG slaves receive the WEIGHTS array
15557           call MPI_Bcast(weights(1),n_ene,&
15558               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15559           wsc=weights(1)
15560           wscp=weights(2)
15561           welec=weights(3)
15562           wcorr=weights(4)
15563           wcorr5=weights(5)
15564           wcorr6=weights(6)
15565           wel_loc=weights(7)
15566           wturn3=weights(8)
15567           wturn4=weights(9)
15568           wturn6=weights(10)
15569           wang=weights(11)
15570           wscloc=weights(12)
15571           wtor=weights(13)
15572           wtor_d=weights(14)
15573           wstrain=weights(15)
15574           wvdwpp=weights(16)
15575           wbond=weights(17)
15576           scal14=weights(18)
15577           wsccor=weights(21)
15578         endif
15579         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15580           king,FG_COMM,IERR)
15581          time_Bcast=time_Bcast+MPI_Wtime()-time00
15582          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15583 !        call chainbuild_cart
15584 !        call int_from_cart1(.false.)
15585       endif
15586 !      write (iout,*) 'Processor',myrank,
15587 !     &  ' calling etotal_short ipot=',ipot
15588 !      call flush(iout)
15589 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15590 #endif
15591 !d    print *,'nnt=',nnt,' nct=',nct
15592 !
15593 !elwrite(iout,*)"in etotal long"
15594 ! Compute the side-chain and electrostatic interaction energy
15595 !
15596       goto (101,102,103,104,105,106) ipot
15597 ! Lennard-Jones potential.
15598   101 call elj_long(evdw)
15599 !d    print '(a)','Exit ELJ'
15600       goto 107
15601 ! Lennard-Jones-Kihara potential (shifted).
15602   102 call eljk_long(evdw)
15603       goto 107
15604 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15605   103 call ebp_long(evdw)
15606       goto 107
15607 ! Gay-Berne potential (shifted LJ, angular dependence).
15608   104 call egb_long(evdw)
15609       goto 107
15610 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15611   105 call egbv_long(evdw)
15612       goto 107
15613 ! Soft-sphere potential
15614   106 call e_softsphere(evdw)
15615 !
15616 ! Calculate electrostatic (H-bonding) energy of the main chain.
15617 !
15618   107 continue
15619       call vec_and_deriv
15620       if (ipot.lt.6) then
15621 #ifdef SPLITELE
15622          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15623              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15624              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15625              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15626 #else
15627          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15628              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15629              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15630              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15631 #endif
15632            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15633          else
15634             ees=0
15635             evdw1=0
15636             eel_loc=0
15637             eello_turn3=0
15638             eello_turn4=0
15639          endif
15640       else
15641 !        write (iout,*) "Soft-spheer ELEC potential"
15642         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15643          eello_turn4)
15644       endif
15645 !
15646 ! Calculate excluded-volume interaction energy between peptide groups
15647 ! and side chains.
15648 !
15649       if (ipot.lt.6) then
15650        if(wscp.gt.0d0) then
15651         call escp_long(evdw2,evdw2_14)
15652        else
15653         evdw2=0
15654         evdw2_14=0
15655        endif
15656       else
15657         call escp_soft_sphere(evdw2,evdw2_14)
15658       endif
15659 !
15660 ! 12/1/95 Multi-body terms
15661 !
15662       n_corr=0
15663       n_corr1=0
15664       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15665           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15666          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15667 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15668 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15669       else
15670          ecorr=0.0d0
15671          ecorr5=0.0d0
15672          ecorr6=0.0d0
15673          eturn6=0.0d0
15674       endif
15675       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15676          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15677       endif
15678 !
15679 ! If performing constraint dynamics, call the constraint energy
15680 !  after the equilibration time
15681       if(usampl.and.totT.gt.eq_time) then
15682          call EconstrQ
15683          call Econstr_back
15684       else
15685          Uconst=0.0d0
15686          Uconst_back=0.0d0
15687       endif
15688 !
15689 ! Sum the energies
15690 !
15691       do i=1,n_ene
15692         energia(i)=0.0d0
15693       enddo
15694       energia(1)=evdw
15695 #ifdef SCP14
15696       energia(2)=evdw2-evdw2_14
15697       energia(18)=evdw2_14
15698 #else
15699       energia(2)=evdw2
15700       energia(18)=0.0d0
15701 #endif
15702 #ifdef SPLITELE
15703       energia(3)=ees
15704       energia(16)=evdw1
15705 #else
15706       energia(3)=ees+evdw1
15707       energia(16)=0.0d0
15708 #endif
15709       energia(4)=ecorr
15710       energia(5)=ecorr5
15711       energia(6)=ecorr6
15712       energia(7)=eel_loc
15713       energia(8)=eello_turn3
15714       energia(9)=eello_turn4
15715       energia(10)=eturn6
15716       energia(20)=Uconst+Uconst_back
15717       call sum_energy(energia,.true.)
15718 !      write (iout,*) "Exit ETOTAL_LONG"
15719       call flush(iout)
15720       return
15721       end subroutine etotal_long
15722 !-----------------------------------------------------------------------------
15723       subroutine etotal_short(energia)
15724 !
15725 ! Compute the short-range fast-varying contributions to the energy
15726 !
15727 !      implicit real*8 (a-h,o-z)
15728 !      include 'DIMENSIONS'
15729 #ifndef ISNAN
15730       external proc_proc
15731 #ifdef WINPGI
15732 !MS$ATTRIBUTES C ::  proc_proc
15733 #endif
15734 #endif
15735 #ifdef MPI
15736       include "mpif.h"
15737       integer :: ierror,ierr
15738       real(kind=8),dimension(n_ene) :: weights_
15739       real(kind=8) :: time00
15740 #endif
15741 !      include 'COMMON.SETUP'
15742 !      include 'COMMON.IOUNITS'
15743 !      include 'COMMON.FFIELD'
15744 !      include 'COMMON.DERIV'
15745 !      include 'COMMON.INTERACT'
15746 !      include 'COMMON.SBRIDGE'
15747 !      include 'COMMON.CHAIN'
15748 !      include 'COMMON.VAR'
15749 !      include 'COMMON.LOCAL'
15750       real(kind=8),dimension(0:n_ene) :: energia
15751 !el local variables
15752       integer :: i,nres6
15753       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15754       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15755       nres6=6*nres
15756
15757 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15758 !      call flush(iout)
15759       if (modecalc.eq.12.or.modecalc.eq.14) then
15760 #ifdef MPI
15761         if (fg_rank.eq.0) call int_from_cart1(.false.)
15762 #else
15763         call int_from_cart1(.false.)
15764 #endif
15765       endif
15766 #ifdef MPI
15767 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15768 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15769 !      call flush(iout)
15770       if (nfgtasks.gt.1) then
15771         time00=MPI_Wtime()
15772 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15773         if (fg_rank.eq.0) then
15774           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15775 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15776 !          call flush(iout)
15777 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15778 ! FG slaves as WEIGHTS array.
15779           weights_(1)=wsc
15780           weights_(2)=wscp
15781           weights_(3)=welec
15782           weights_(4)=wcorr
15783           weights_(5)=wcorr5
15784           weights_(6)=wcorr6
15785           weights_(7)=wel_loc
15786           weights_(8)=wturn3
15787           weights_(9)=wturn4
15788           weights_(10)=wturn6
15789           weights_(11)=wang
15790           weights_(12)=wscloc
15791           weights_(13)=wtor
15792           weights_(14)=wtor_d
15793           weights_(15)=wstrain
15794           weights_(16)=wvdwpp
15795           weights_(17)=wbond
15796           weights_(18)=scal14
15797           weights_(21)=wsccor
15798 ! FG Master broadcasts the WEIGHTS_ array
15799           call MPI_Bcast(weights_(1),n_ene,&
15800               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15801         else
15802 ! FG slaves receive the WEIGHTS array
15803           call MPI_Bcast(weights(1),n_ene,&
15804               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15805           wsc=weights(1)
15806           wscp=weights(2)
15807           welec=weights(3)
15808           wcorr=weights(4)
15809           wcorr5=weights(5)
15810           wcorr6=weights(6)
15811           wel_loc=weights(7)
15812           wturn3=weights(8)
15813           wturn4=weights(9)
15814           wturn6=weights(10)
15815           wang=weights(11)
15816           wscloc=weights(12)
15817           wtor=weights(13)
15818           wtor_d=weights(14)
15819           wstrain=weights(15)
15820           wvdwpp=weights(16)
15821           wbond=weights(17)
15822           scal14=weights(18)
15823           wsccor=weights(21)
15824         endif
15825 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15826         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15827           king,FG_COMM,IERR)
15828 !        write (iout,*) "Processor",myrank," BROADCAST c"
15829         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15830           king,FG_COMM,IERR)
15831 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15832         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15833           king,FG_COMM,IERR)
15834 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15835         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15836           king,FG_COMM,IERR)
15837 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15838         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15839           king,FG_COMM,IERR)
15840 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15841         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15842           king,FG_COMM,IERR)
15843 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15844         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15845           king,FG_COMM,IERR)
15846 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15847         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15848           king,FG_COMM,IERR)
15849 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15850         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15851           king,FG_COMM,IERR)
15852          time_Bcast=time_Bcast+MPI_Wtime()-time00
15853 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15854       endif
15855 !      write (iout,*) 'Processor',myrank,
15856 !     &  ' calling etotal_short ipot=',ipot
15857 !      call flush(iout)
15858 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15859 #endif
15860 !      call int_from_cart1(.false.)
15861 !
15862 ! Compute the side-chain and electrostatic interaction energy
15863 !
15864       goto (101,102,103,104,105,106) ipot
15865 ! Lennard-Jones potential.
15866   101 call elj_short(evdw)
15867 !d    print '(a)','Exit ELJ'
15868       goto 107
15869 ! Lennard-Jones-Kihara potential (shifted).
15870   102 call eljk_short(evdw)
15871       goto 107
15872 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15873   103 call ebp_short(evdw)
15874       goto 107
15875 ! Gay-Berne potential (shifted LJ, angular dependence).
15876   104 call egb_short(evdw)
15877       goto 107
15878 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15879   105 call egbv_short(evdw)
15880       goto 107
15881 ! Soft-sphere potential - already dealt with in the long-range part
15882   106 evdw=0.0d0
15883 !  106 call e_softsphere_short(evdw)
15884 !
15885 ! Calculate electrostatic (H-bonding) energy of the main chain.
15886 !
15887   107 continue
15888 !
15889 ! Calculate the short-range part of Evdwpp
15890 !
15891       call evdwpp_short(evdw1)
15892 !
15893 ! Calculate the short-range part of ESCp
15894 !
15895       if (ipot.lt.6) then
15896         call escp_short(evdw2,evdw2_14)
15897       endif
15898 !
15899 ! Calculate the bond-stretching energy
15900 !
15901       call ebond(estr)
15902 !
15903 ! Calculate the disulfide-bridge and other energy and the contributions
15904 ! from other distance constraints.
15905       call edis(ehpb)
15906 !
15907 ! Calculate the virtual-bond-angle energy.
15908 !
15909       call ebend(ebe,ethetacnstr)
15910 !
15911 ! Calculate the SC local energy.
15912 !
15913       call vec_and_deriv
15914       call esc(escloc)
15915 !
15916 ! Calculate the virtual-bond torsional energy.
15917 !
15918       call etor(etors,edihcnstr)
15919 !
15920 ! 6/23/01 Calculate double-torsional energy
15921 !
15922       call etor_d(etors_d)
15923 !
15924 ! 21/5/07 Calculate local sicdechain correlation energy
15925 !
15926       if (wsccor.gt.0.0d0) then
15927         call eback_sc_corr(esccor)
15928       else
15929         esccor=0.0d0
15930       endif
15931 !
15932 ! Put energy components into an array
15933 !
15934       do i=1,n_ene
15935         energia(i)=0.0d0
15936       enddo
15937       energia(1)=evdw
15938 #ifdef SCP14
15939       energia(2)=evdw2-evdw2_14
15940       energia(18)=evdw2_14
15941 #else
15942       energia(2)=evdw2
15943       energia(18)=0.0d0
15944 #endif
15945 #ifdef SPLITELE
15946       energia(16)=evdw1
15947 #else
15948       energia(3)=evdw1
15949 #endif
15950       energia(11)=ebe
15951       energia(12)=escloc
15952       energia(13)=etors
15953       energia(14)=etors_d
15954       energia(15)=ehpb
15955       energia(17)=estr
15956       energia(19)=edihcnstr
15957       energia(21)=esccor
15958 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15959       call flush(iout)
15960       call sum_energy(energia,.true.)
15961 !      write (iout,*) "Exit ETOTAL_SHORT"
15962       call flush(iout)
15963       return
15964       end subroutine etotal_short
15965 !-----------------------------------------------------------------------------
15966 ! gnmr1.f
15967 !-----------------------------------------------------------------------------
15968       real(kind=8) function gnmr1(y,ymin,ymax)
15969 !      implicit none
15970       real(kind=8) :: y,ymin,ymax
15971       real(kind=8) :: wykl=4.0d0
15972       if (y.lt.ymin) then
15973         gnmr1=(ymin-y)**wykl/wykl
15974       else if (y.gt.ymax) then
15975         gnmr1=(y-ymax)**wykl/wykl
15976       else
15977         gnmr1=0.0d0
15978       endif
15979       return
15980       end function gnmr1
15981 !-----------------------------------------------------------------------------
15982       real(kind=8) function gnmr1prim(y,ymin,ymax)
15983 !      implicit none
15984       real(kind=8) :: y,ymin,ymax
15985       real(kind=8) :: wykl=4.0d0
15986       if (y.lt.ymin) then
15987         gnmr1prim=-(ymin-y)**(wykl-1)
15988       else if (y.gt.ymax) then
15989         gnmr1prim=(y-ymax)**(wykl-1)
15990       else
15991         gnmr1prim=0.0d0
15992       endif
15993       return
15994       end function gnmr1prim
15995 !----------------------------------------------------------------------------
15996       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15997       real(kind=8) y,ymin,ymax,sigma
15998       real(kind=8) wykl /4.0d0/
15999       if (y.lt.ymin) then
16000         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16001       else if (y.gt.ymax) then
16002         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16003       else
16004         rlornmr1=0.0d0
16005       endif
16006       return
16007       end function rlornmr1
16008 !------------------------------------------------------------------------------
16009       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16010       real(kind=8) y,ymin,ymax,sigma
16011       real(kind=8) wykl /4.0d0/
16012       if (y.lt.ymin) then
16013         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16014         ((ymin-y)**wykl+sigma**wykl)**2
16015       else if (y.gt.ymax) then
16016         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16017         ((y-ymax)**wykl+sigma**wykl)**2
16018       else
16019         rlornmr1prim=0.0d0
16020       endif
16021       return
16022       end function rlornmr1prim
16023
16024       real(kind=8) function harmonic(y,ymax)
16025 !      implicit none
16026       real(kind=8) :: y,ymax
16027       real(kind=8) :: wykl=2.0d0
16028       harmonic=(y-ymax)**wykl
16029       return
16030       end function harmonic
16031 !-----------------------------------------------------------------------------
16032       real(kind=8) function harmonicprim(y,ymax)
16033       real(kind=8) :: y,ymin,ymax
16034       real(kind=8) :: wykl=2.0d0
16035       harmonicprim=(y-ymax)*wykl
16036       return
16037       end function harmonicprim
16038 !-----------------------------------------------------------------------------
16039 ! gradient_p.F
16040 !-----------------------------------------------------------------------------
16041       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16042
16043       use io_base, only:intout,briefout
16044 !      implicit real*8 (a-h,o-z)
16045 !      include 'DIMENSIONS'
16046 !      include 'COMMON.CHAIN'
16047 !      include 'COMMON.DERIV'
16048 !      include 'COMMON.VAR'
16049 !      include 'COMMON.INTERACT'
16050 !      include 'COMMON.FFIELD'
16051 !      include 'COMMON.MD'
16052 !      include 'COMMON.IOUNITS'
16053       real(kind=8),external :: ufparm
16054       integer :: uiparm(1)
16055       real(kind=8) :: urparm(1)
16056       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16057       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16058       integer :: n,nf,ind,ind1,i,k,j
16059 !
16060 ! This subroutine calculates total internal coordinate gradient.
16061 ! Depending on the number of function evaluations, either whole energy
16062 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16063 ! internal coordinates are reevaluated or only the cartesian-in-internal
16064 ! coordinate derivatives are evaluated. The subroutine was designed to work
16065 ! with SUMSL.
16066 !
16067 !
16068       icg=mod(nf,2)+1
16069
16070 !d      print *,'grad',nf,icg
16071       if (nf-nfl+1) 20,30,40
16072    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16073 !    write (iout,*) 'grad 20'
16074       if (nf.eq.0) return
16075       goto 40
16076    30 call var_to_geom(n,x)
16077       call chainbuild
16078 !    write (iout,*) 'grad 30'
16079 !
16080 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16081 !
16082    40 call cartder
16083 !     write (iout,*) 'grad 40'
16084 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16085 !
16086 ! Convert the Cartesian gradient into internal-coordinate gradient.
16087 !
16088       ind=0
16089       ind1=0
16090       do i=1,nres-2
16091       gthetai=0.0D0
16092       gphii=0.0D0
16093       do j=i+1,nres-1
16094           ind=ind+1
16095 !         ind=indmat(i,j)
16096 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16097         do k=1,3
16098             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16099           enddo
16100         do k=1,3
16101           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16102           enddo
16103         enddo
16104       do j=i+1,nres-1
16105           ind1=ind1+1
16106 !         ind1=indmat(i,j)
16107 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16108         do k=1,3
16109           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16110           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16111           enddo
16112         enddo
16113       if (i.gt.1) g(i-1)=gphii
16114       if (n.gt.nphi) g(nphi+i)=gthetai
16115       enddo
16116       if (n.le.nphi+ntheta) goto 10
16117       do i=2,nres-1
16118       if (itype(i,1).ne.10) then
16119           galphai=0.0D0
16120         gomegai=0.0D0
16121         do k=1,3
16122           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16123           enddo
16124         do k=1,3
16125           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16126           enddo
16127           g(ialph(i,1))=galphai
16128         g(ialph(i,1)+nside)=gomegai
16129         endif
16130       enddo
16131 !
16132 ! Add the components corresponding to local energy terms.
16133 !
16134    10 continue
16135       do i=1,nvar
16136 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16137         g(i)=g(i)+gloc(i,icg)
16138       enddo
16139 ! Uncomment following three lines for diagnostics.
16140 !d    call intout
16141 !elwrite(iout,*) "in gradient after calling intout"
16142 !d    call briefout(0,0.0d0)
16143 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16144       return
16145       end subroutine gradient
16146 !-----------------------------------------------------------------------------
16147       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16148
16149       use comm_chu
16150 !      implicit real*8 (a-h,o-z)
16151 !      include 'DIMENSIONS'
16152 !      include 'COMMON.DERIV'
16153 !      include 'COMMON.IOUNITS'
16154 !      include 'COMMON.GEO'
16155       integer :: n,nf
16156 !el      integer :: jjj
16157 !el      common /chuju/ jjj
16158       real(kind=8) :: energia(0:n_ene)
16159       integer :: uiparm(1)
16160       real(kind=8) :: urparm(1)
16161       real(kind=8) :: f
16162       real(kind=8),external :: ufparm
16163       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16164 !     if (jjj.gt.0) then
16165 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16166 !     endif
16167       nfl=nf
16168       icg=mod(nf,2)+1
16169 !d      print *,'func',nf,nfl,icg
16170       call var_to_geom(n,x)
16171       call zerograd
16172       call chainbuild
16173 !d    write (iout,*) 'ETOTAL called from FUNC'
16174       call etotal(energia)
16175       call sum_gradient
16176       f=energia(0)
16177 !     if (jjj.gt.0) then
16178 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16179 !       write (iout,*) 'f=',etot
16180 !       jjj=0
16181 !     endif
16182       return
16183       end subroutine func
16184 !-----------------------------------------------------------------------------
16185       subroutine cartgrad
16186 !      implicit real*8 (a-h,o-z)
16187 !      include 'DIMENSIONS'
16188       use energy_data
16189       use MD_data, only: totT,usampl,eq_time
16190 #ifdef MPI
16191       include 'mpif.h'
16192 #endif
16193 !      include 'COMMON.CHAIN'
16194 !      include 'COMMON.DERIV'
16195 !      include 'COMMON.VAR'
16196 !      include 'COMMON.INTERACT'
16197 !      include 'COMMON.FFIELD'
16198 !      include 'COMMON.MD'
16199 !      include 'COMMON.IOUNITS'
16200 !      include 'COMMON.TIME1'
16201 !
16202       integer :: i,j
16203
16204 ! This subrouting calculates total Cartesian coordinate gradient.
16205 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16206 !
16207 !#define DEBUG
16208 #ifdef TIMING
16209       time00=MPI_Wtime()
16210 #endif
16211       icg=1
16212       call sum_gradient
16213 #ifdef TIMING
16214 #endif
16215 !el      write (iout,*) "After sum_gradient"
16216 #ifdef DEBUG
16217 !el      write (iout,*) "After sum_gradient"
16218       do i=1,nres-1
16219         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16220         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16221       enddo
16222 #endif
16223 ! If performing constraint dynamics, add the gradients of the constraint energy
16224       if(usampl.and.totT.gt.eq_time) then
16225          do i=1,nct
16226            do j=1,3
16227              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16228              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16229            enddo
16230          enddo
16231          do i=1,nres-3
16232            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16233          enddo
16234          do i=1,nres-2
16235            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16236          enddo
16237       endif
16238 !elwrite (iout,*) "After sum_gradient"
16239 #ifdef TIMING
16240       time01=MPI_Wtime()
16241 #endif
16242       call intcartderiv
16243 !elwrite (iout,*) "After sum_gradient"
16244 #ifdef TIMING
16245       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16246 #endif
16247 !     call checkintcartgrad
16248 !     write(iout,*) 'calling int_to_cart'
16249 #ifdef DEBUG
16250       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16251 #endif
16252       do i=0,nct
16253         do j=1,3
16254           gcart(j,i)=gradc(j,i,icg)
16255           gxcart(j,i)=gradx(j,i,icg)
16256 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16257         enddo
16258 #ifdef DEBUG
16259         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16260           (gxcart(j,i),j=1,3),gloc(i,icg)
16261 #endif
16262       enddo
16263 #ifdef TIMING
16264       time01=MPI_Wtime()
16265 #endif
16266 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16267       call int_to_cart
16268 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16269
16270 #ifdef TIMING
16271             time_inttocart=time_inttocart+MPI_Wtime()-time01
16272 #endif
16273 #ifdef DEBUG
16274             write (iout,*) "gcart and gxcart after int_to_cart"
16275             do i=0,nres-1
16276             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16277                 (gxcart(j,i),j=1,3)
16278             enddo
16279 #endif
16280 #ifdef CARGRAD
16281 #ifdef DEBUG
16282             write (iout,*) "CARGRAD"
16283 #endif
16284             do i=nres,0,-1
16285             do j=1,3
16286               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16287       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16288             enddo
16289       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16290       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16291             enddo
16292       ! Correction: dummy residues
16293             if (nnt.gt.1) then
16294               do j=1,3
16295       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16296                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16297               enddo
16298             endif
16299             if (nct.lt.nres) then
16300               do j=1,3
16301       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16302                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16303               enddo
16304             endif
16305 #endif
16306 #ifdef TIMING
16307             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16308 #endif
16309 !#undef DEBUG
16310             return
16311             end subroutine cartgrad
16312       !-----------------------------------------------------------------------------
16313             subroutine zerograd
16314       !      implicit real*8 (a-h,o-z)
16315       !      include 'DIMENSIONS'
16316       !      include 'COMMON.DERIV'
16317       !      include 'COMMON.CHAIN'
16318       !      include 'COMMON.VAR'
16319       !      include 'COMMON.MD'
16320       !      include 'COMMON.SCCOR'
16321       !
16322       !el local variables
16323             integer :: i,j,intertyp,k
16324       ! Initialize Cartesian-coordinate gradient
16325       !
16326       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16327       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16328
16329       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16330       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16331       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16332       !      allocate(gradcorr_long(3,nres))
16333       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16334       !      allocate(gcorr6_turn_long(3,nres))
16335       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16336
16337       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16338
16339       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16340       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16341
16342       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16343       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16344
16345       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16346       !      allocate(gscloc(3,nres)) !(3,maxres)
16347       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16348
16349
16350
16351       !      common /deriv_scloc/
16352       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16353       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16354       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16355       !      common /mpgrad/
16356       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16357
16358
16359
16360       !          gradc(j,i,icg)=0.0d0
16361       !          gradx(j,i,icg)=0.0d0
16362
16363       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16364       !elwrite(iout,*) "icg",icg
16365             do i=-1,nres
16366             do j=1,3
16367               gvdwx(j,i)=0.0D0
16368               gradx_scp(j,i)=0.0D0
16369               gvdwc(j,i)=0.0D0
16370               gvdwc_scp(j,i)=0.0D0
16371               gvdwc_scpp(j,i)=0.0d0
16372               gelc(j,i)=0.0D0
16373               gelc_long(j,i)=0.0D0
16374               gradb(j,i)=0.0d0
16375               gradbx(j,i)=0.0d0
16376               gvdwpp(j,i)=0.0d0
16377               gel_loc(j,i)=0.0d0
16378               gel_loc_long(j,i)=0.0d0
16379               ghpbc(j,i)=0.0D0
16380               ghpbx(j,i)=0.0D0
16381               gcorr3_turn(j,i)=0.0d0
16382               gcorr4_turn(j,i)=0.0d0
16383               gradcorr(j,i)=0.0d0
16384               gradcorr_long(j,i)=0.0d0
16385               gradcorr5_long(j,i)=0.0d0
16386               gradcorr6_long(j,i)=0.0d0
16387               gcorr6_turn_long(j,i)=0.0d0
16388               gradcorr5(j,i)=0.0d0
16389               gradcorr6(j,i)=0.0d0
16390               gcorr6_turn(j,i)=0.0d0
16391               gsccorc(j,i)=0.0d0
16392               gsccorx(j,i)=0.0d0
16393               gradc(j,i,icg)=0.0d0
16394               gradx(j,i,icg)=0.0d0
16395               gscloc(j,i)=0.0d0
16396               gsclocx(j,i)=0.0d0
16397               gliptran(j,i)=0.0d0
16398               gliptranx(j,i)=0.0d0
16399               gliptranc(j,i)=0.0d0
16400               gshieldx(j,i)=0.0d0
16401               gshieldc(j,i)=0.0d0
16402               gshieldc_loc(j,i)=0.0d0
16403               gshieldx_ec(j,i)=0.0d0
16404               gshieldc_ec(j,i)=0.0d0
16405               gshieldc_loc_ec(j,i)=0.0d0
16406               gshieldx_t3(j,i)=0.0d0
16407               gshieldc_t3(j,i)=0.0d0
16408               gshieldc_loc_t3(j,i)=0.0d0
16409               gshieldx_t4(j,i)=0.0d0
16410               gshieldc_t4(j,i)=0.0d0
16411               gshieldc_loc_t4(j,i)=0.0d0
16412               gshieldx_ll(j,i)=0.0d0
16413               gshieldc_ll(j,i)=0.0d0
16414               gshieldc_loc_ll(j,i)=0.0d0
16415               gg_tube(j,i)=0.0d0
16416               gg_tube_sc(j,i)=0.0d0
16417               gradafm(j,i)=0.0d0
16418               gradb_nucl(j,i)=0.0d0
16419               gradbx_nucl(j,i)=0.0d0
16420               gvdwpp_nucl(j,i)=0.0d0
16421               gvdwpp(j,i)=0.0d0
16422               gelpp(j,i)=0.0d0
16423               gvdwpsb(j,i)=0.0d0
16424               gvdwpsb1(j,i)=0.0d0
16425               gvdwsbc(j,i)=0.0d0
16426               gvdwsbx(j,i)=0.0d0
16427               gelsbc(j,i)=0.0d0
16428               gradcorr_nucl(j,i)=0.0d0
16429               gradcorr3_nucl(j,i)=0.0d0
16430               gradxorr_nucl(j,i)=0.0d0
16431               gradxorr3_nucl(j,i)=0.0d0
16432               gelsbx(j,i)=0.0d0
16433               gsbloc(j,i)=0.0d0
16434               gsblocx(j,i)=0.0d0
16435               gradpepcat(j,i)=0.0d0
16436               gradpepcatx(j,i)=0.0d0
16437               gradcatcat(j,i)=0.0d0
16438               gvdwx_scbase(j,i)=0.0d0
16439               gvdwc_scbase(j,i)=0.0d0
16440               gvdwx_pepbase(j,i)=0.0d0
16441               gvdwc_pepbase(j,i)=0.0d0
16442               gvdwx_scpho(j,i)=0.0d0
16443               gvdwc_scpho(j,i)=0.0d0
16444               gvdwc_peppho(j,i)=0.0d0
16445             enddo
16446              enddo
16447             do i=0,nres
16448             do j=1,3
16449               do intertyp=1,3
16450                gloc_sc(intertyp,i,icg)=0.0d0
16451               enddo
16452             enddo
16453             enddo
16454             do i=1,nres
16455              do j=1,maxcontsshi
16456              shield_list(j,i)=0
16457             do k=1,3
16458       !C           print *,i,j,k
16459                grad_shield_side(k,j,i)=0.0d0
16460                grad_shield_loc(k,j,i)=0.0d0
16461              enddo
16462              enddo
16463              ishield_list(i)=0
16464             enddo
16465
16466       !
16467       ! Initialize the gradient of local energy terms.
16468       !
16469       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16470       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16471       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16472       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16473       !      allocate(gel_loc_turn3(nres))
16474       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16475       !      allocate(gsccor_loc(nres))      !(maxres)
16476
16477             do i=1,4*nres
16478             gloc(i,icg)=0.0D0
16479             enddo
16480             do i=1,nres
16481             gel_loc_loc(i)=0.0d0
16482             gcorr_loc(i)=0.0d0
16483             g_corr5_loc(i)=0.0d0
16484             g_corr6_loc(i)=0.0d0
16485             gel_loc_turn3(i)=0.0d0
16486             gel_loc_turn4(i)=0.0d0
16487             gel_loc_turn6(i)=0.0d0
16488             gsccor_loc(i)=0.0d0
16489             enddo
16490       ! initialize gcart and gxcart
16491       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16492             do i=0,nres
16493             do j=1,3
16494               gcart(j,i)=0.0d0
16495               gxcart(j,i)=0.0d0
16496             enddo
16497             enddo
16498             return
16499             end subroutine zerograd
16500       !-----------------------------------------------------------------------------
16501             real(kind=8) function fdum()
16502             fdum=0.0D0
16503             return
16504             end function fdum
16505       !-----------------------------------------------------------------------------
16506       ! intcartderiv.F
16507       !-----------------------------------------------------------------------------
16508             subroutine intcartderiv
16509       !      implicit real*8 (a-h,o-z)
16510       !      include 'DIMENSIONS'
16511 #ifdef MPI
16512             include 'mpif.h'
16513 #endif
16514       !      include 'COMMON.SETUP'
16515       !      include 'COMMON.CHAIN'
16516       !      include 'COMMON.VAR'
16517       !      include 'COMMON.GEO'
16518       !      include 'COMMON.INTERACT'
16519       !      include 'COMMON.DERIV'
16520       !      include 'COMMON.IOUNITS'
16521       !      include 'COMMON.LOCAL'
16522       !      include 'COMMON.SCCOR'
16523             real(kind=8) :: pi4,pi34
16524             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16525             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16526                       dcosomega,dsinomega !(3,3,maxres)
16527             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16528
16529             integer :: i,j,k
16530             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16531                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16532                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16533                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16534             integer :: nres2
16535             nres2=2*nres
16536
16537       !el from module energy-------------
16538       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16539       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16540       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16541
16542       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16543       !el      allocate(dsintau(3,3,3,0:nres2))
16544       !el      allocate(dtauangle(3,3,3,0:nres2))
16545       !el      allocate(domicron(3,2,2,0:nres2))
16546       !el      allocate(dcosomicron(3,2,2,0:nres2))
16547
16548
16549
16550 #if defined(MPI) && defined(PARINTDER)
16551             if (nfgtasks.gt.1 .and. me.eq.king) &
16552             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16553 #endif
16554             pi4 = 0.5d0*pipol
16555             pi34 = 3*pi4
16556
16557       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16558       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16559
16560       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16561             do i=1,nres
16562             do j=1,3
16563               dtheta(j,1,i)=0.0d0
16564               dtheta(j,2,i)=0.0d0
16565               dphi(j,1,i)=0.0d0
16566               dphi(j,2,i)=0.0d0
16567               dphi(j,3,i)=0.0d0
16568             enddo
16569             enddo
16570       ! Derivatives of theta's
16571 #if defined(MPI) && defined(PARINTDER)
16572       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16573             do i=max0(ithet_start-1,3),ithet_end
16574 #else
16575             do i=3,nres
16576 #endif
16577             cost=dcos(theta(i))
16578             sint=sqrt(1-cost*cost)
16579             do j=1,3
16580               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16581               vbld(i-1)
16582               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16583               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16584               vbld(i)
16585               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16586             enddo
16587             enddo
16588 #if defined(MPI) && defined(PARINTDER)
16589       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16590             do i=max0(ithet_start-1,3),ithet_end
16591 #else
16592             do i=3,nres
16593 #endif
16594             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16595             cost1=dcos(omicron(1,i))
16596             sint1=sqrt(1-cost1*cost1)
16597             cost2=dcos(omicron(2,i))
16598             sint2=sqrt(1-cost2*cost2)
16599              do j=1,3
16600       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16601               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16602               cost1*dc_norm(j,i-2))/ &
16603               vbld(i-1)
16604               domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16605               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16606               +cost1*(dc_norm(j,i-1+nres)))/ &
16607               vbld(i-1+nres)
16608               domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16609       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16610       !C Looks messy but better than if in loop
16611               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16612               +cost2*dc_norm(j,i-1))/ &
16613               vbld(i)
16614               domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16615               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16616                +cost2*(-dc_norm(j,i-1+nres)))/ &
16617               vbld(i-1+nres)
16618       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16619               domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16620             enddo
16621              endif
16622             enddo
16623       !elwrite(iout,*) "after vbld write"
16624       ! Derivatives of phi:
16625       ! If phi is 0 or 180 degrees, then the formulas
16626       ! have to be derived by power series expansion of the
16627       ! conventional formulas around 0 and 180.
16628 #ifdef PARINTDER
16629             do i=iphi1_start,iphi1_end
16630 #else
16631             do i=4,nres
16632 #endif
16633       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16634       ! the conventional case
16635             sint=dsin(theta(i))
16636             sint1=dsin(theta(i-1))
16637             sing=dsin(phi(i))
16638             cost=dcos(theta(i))
16639             cost1=dcos(theta(i-1))
16640             cosg=dcos(phi(i))
16641             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16642             fac0=1.0d0/(sint1*sint)
16643             fac1=cost*fac0
16644             fac2=cost1*fac0
16645             fac3=cosg*cost1/(sint1*sint1)
16646             fac4=cosg*cost/(sint*sint)
16647       !    Obtaining the gamma derivatives from sine derivative
16648              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16649                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16650                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16651              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16652              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16653              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16654              do j=1,3
16655                 ctgt=cost/sint
16656                 ctgt1=cost1/sint1
16657                 cosg_inv=1.0d0/cosg
16658                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16659                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16660                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16661                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16662                 dsinphi(j,2,i)= &
16663                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16664                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16665                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16666                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16667                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16668       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16669                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16670                 endif
16671       ! Bug fixed 3/24/05 (AL)
16672              enddo
16673       !   Obtaining the gamma derivatives from cosine derivative
16674             else
16675                do j=1,3
16676                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16677                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16678                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16679                dc_norm(j,i-3))/vbld(i-2)
16680                dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16681                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16682                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16683                dcostheta(j,1,i)
16684                dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16685                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16686                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16687                dc_norm(j,i-1))/vbld(i)
16688                dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16689                endif
16690              enddo
16691             endif
16692             enddo
16693       !alculate derivative of Tauangle
16694 #ifdef PARINTDER
16695             do i=itau_start,itau_end
16696 #else
16697             do i=3,nres
16698       !elwrite(iout,*) " vecpr",i,nres
16699 #endif
16700              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16701       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16702       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16703       !c dtauangle(j,intertyp,dervityp,residue number)
16704       !c INTERTYP=1 SC...Ca...Ca..Ca
16705       ! the conventional case
16706             sint=dsin(theta(i))
16707             sint1=dsin(omicron(2,i-1))
16708             sing=dsin(tauangle(1,i))
16709             cost=dcos(theta(i))
16710             cost1=dcos(omicron(2,i-1))
16711             cosg=dcos(tauangle(1,i))
16712       !elwrite(iout,*) " vecpr5",i,nres
16713             do j=1,3
16714       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16715       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16716             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16717       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16718             enddo
16719             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16720             fac0=1.0d0/(sint1*sint)
16721             fac1=cost*fac0
16722             fac2=cost1*fac0
16723             fac3=cosg*cost1/(sint1*sint1)
16724             fac4=cosg*cost/(sint*sint)
16725       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16726       !    Obtaining the gamma derivatives from sine derivative
16727              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16728                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16729                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16730              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16731              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16732              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16733             do j=1,3
16734                 ctgt=cost/sint
16735                 ctgt1=cost1/sint1
16736                 cosg_inv=1.0d0/cosg
16737                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16738              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16739              *vbld_inv(i-2+nres)
16740                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16741                 dsintau(j,1,2,i)= &
16742                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16743                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16744       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16745                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16746       ! Bug fixed 3/24/05 (AL)
16747                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16748                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16749       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16750                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16751              enddo
16752       !   Obtaining the gamma derivatives from cosine derivative
16753             else
16754                do j=1,3
16755                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16756                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16757                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16758                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16759                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16760                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16761                dcostheta(j,1,i)
16762                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16763                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16764                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16765                dc_norm(j,i-1))/vbld(i)
16766                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16767       !         write (iout,*) "else",i
16768              enddo
16769             endif
16770       !        do k=1,3
16771       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16772       !        enddo
16773             enddo
16774       !C Second case Ca...Ca...Ca...SC
16775 #ifdef PARINTDER
16776             do i=itau_start,itau_end
16777 #else
16778             do i=4,nres
16779 #endif
16780              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16781               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16782       ! the conventional case
16783             sint=dsin(omicron(1,i))
16784             sint1=dsin(theta(i-1))
16785             sing=dsin(tauangle(2,i))
16786             cost=dcos(omicron(1,i))
16787             cost1=dcos(theta(i-1))
16788             cosg=dcos(tauangle(2,i))
16789       !        do j=1,3
16790       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16791       !        enddo
16792             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16793             fac0=1.0d0/(sint1*sint)
16794             fac1=cost*fac0
16795             fac2=cost1*fac0
16796             fac3=cosg*cost1/(sint1*sint1)
16797             fac4=cosg*cost/(sint*sint)
16798       !    Obtaining the gamma derivatives from sine derivative
16799              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16800                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16801                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16802              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16803              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16804              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16805             do j=1,3
16806                 ctgt=cost/sint
16807                 ctgt1=cost1/sint1
16808                 cosg_inv=1.0d0/cosg
16809                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16810                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16811       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16812       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16813                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16814                 dsintau(j,2,2,i)= &
16815                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16816                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16817       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16818       !     & sing*ctgt*domicron(j,1,2,i),
16819       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16820                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16821       ! Bug fixed 3/24/05 (AL)
16822                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16823                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16824       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16825                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16826              enddo
16827       !   Obtaining the gamma derivatives from cosine derivative
16828             else
16829                do j=1,3
16830                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16831                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16832                dc_norm(j,i-3))/vbld(i-2)
16833                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16834                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16835                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16836                dcosomicron(j,1,1,i)
16837                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16838                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16839                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16840                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16841                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16842       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16843              enddo
16844             endif
16845             enddo
16846
16847       !CC third case SC...Ca...Ca...SC
16848 #ifdef PARINTDER
16849
16850             do i=itau_start,itau_end
16851 #else
16852             do i=3,nres
16853 #endif
16854       ! the conventional case
16855             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16856             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16857             sint=dsin(omicron(1,i))
16858             sint1=dsin(omicron(2,i-1))
16859             sing=dsin(tauangle(3,i))
16860             cost=dcos(omicron(1,i))
16861             cost1=dcos(omicron(2,i-1))
16862             cosg=dcos(tauangle(3,i))
16863             do j=1,3
16864             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16865       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16866             enddo
16867             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16868             fac0=1.0d0/(sint1*sint)
16869             fac1=cost*fac0
16870             fac2=cost1*fac0
16871             fac3=cosg*cost1/(sint1*sint1)
16872             fac4=cosg*cost/(sint*sint)
16873       !    Obtaining the gamma derivatives from sine derivative
16874              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16875                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16876                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16877              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16878              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16879              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16880             do j=1,3
16881                 ctgt=cost/sint
16882                 ctgt1=cost1/sint1
16883                 cosg_inv=1.0d0/cosg
16884                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16885                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16886                   *vbld_inv(i-2+nres)
16887                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16888                 dsintau(j,3,2,i)= &
16889                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16890                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16891                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16892       ! Bug fixed 3/24/05 (AL)
16893                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16894                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16895                   *vbld_inv(i-1+nres)
16896       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16897                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16898              enddo
16899       !   Obtaining the gamma derivatives from cosine derivative
16900             else
16901                do j=1,3
16902                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16903                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16904                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16905                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16906                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16907                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16908                dcosomicron(j,1,1,i)
16909                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16910                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16911                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16912                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16913                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16914       !          write(iout,*) "else",i
16915              enddo
16916             endif
16917             enddo
16918
16919 #ifdef CRYST_SC
16920       !   Derivatives of side-chain angles alpha and omega
16921 #if defined(MPI) && defined(PARINTDER)
16922             do i=ibond_start,ibond_end
16923 #else
16924             do i=2,nres-1
16925 #endif
16926               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16927                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16928                  fac6=fac5/vbld(i)
16929                  fac7=fac5*fac5
16930                  fac8=fac5/vbld(i+1)
16931                  fac9=fac5/vbld(i+nres)
16932                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16933                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16934                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16935                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16936                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16937                  sina=sqrt(1-cosa*cosa)
16938                  sino=dsin(omeg(i))
16939       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16940                  do j=1,3
16941                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16942                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16943                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16944                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16945                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16946                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16947                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16948                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16949                   vbld(i+nres))
16950                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16951                 enddo
16952       ! obtaining the derivatives of omega from sines
16953                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16954                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16955                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16956                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16957                    dsin(theta(i+1)))
16958                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16959                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16960                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16961                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16962                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16963                    coso_inv=1.0d0/dcos(omeg(i))
16964                    do j=1,3
16965                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16966                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16967                    (sino*dc_norm(j,i-1))/vbld(i)
16968                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16969                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16970                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16971                    -sino*dc_norm(j,i)/vbld(i+1)
16972                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16973                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16974                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16975                    vbld(i+nres)
16976                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16977                   enddo
16978                else
16979       !   obtaining the derivatives of omega from cosines
16980                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16981                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16982                  fac12=fac10*sina
16983                  fac13=fac12*fac12
16984                  fac14=sina*sina
16985                  do j=1,3
16986                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16987                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16988                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16989                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16990                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16991                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16992                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16993                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16994                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16995                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16996                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16997                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16998                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16999                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17000                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17001                 enddo
17002               endif
17003              else
17004                do j=1,3
17005                  do k=1,3
17006                    dalpha(k,j,i)=0.0d0
17007                    domega(k,j,i)=0.0d0
17008                  enddo
17009                enddo
17010              endif
17011              enddo
17012 #endif
17013 #if defined(MPI) && defined(PARINTDER)
17014             if (nfgtasks.gt.1) then
17015 #ifdef DEBUG
17016       !d      write (iout,*) "Gather dtheta"
17017       !d      call flush(iout)
17018             write (iout,*) "dtheta before gather"
17019             do i=1,nres
17020             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17021             enddo
17022 #endif
17023             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17024             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17025             king,FG_COMM,IERROR)
17026 #ifdef DEBUG
17027       !d      write (iout,*) "Gather dphi"
17028       !d      call flush(iout)
17029             write (iout,*) "dphi before gather"
17030             do i=1,nres
17031             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17032             enddo
17033 #endif
17034             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17035             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17036             king,FG_COMM,IERROR)
17037       !d      write (iout,*) "Gather dalpha"
17038       !d      call flush(iout)
17039 #ifdef CRYST_SC
17040             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17041             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17042             king,FG_COMM,IERROR)
17043       !d      write (iout,*) "Gather domega"
17044       !d      call flush(iout)
17045             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17046             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17047             king,FG_COMM,IERROR)
17048 #endif
17049             endif
17050 #endif
17051 #ifdef DEBUG
17052             write (iout,*) "dtheta after gather"
17053             do i=1,nres
17054             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17055             enddo
17056             write (iout,*) "dphi after gather"
17057             do i=1,nres
17058             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17059             enddo
17060             write (iout,*) "dalpha after gather"
17061             do i=1,nres
17062             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17063             enddo
17064             write (iout,*) "domega after gather"
17065             do i=1,nres
17066             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17067             enddo
17068 #endif
17069             return
17070             end subroutine intcartderiv
17071       !-----------------------------------------------------------------------------
17072             subroutine checkintcartgrad
17073       !      implicit real*8 (a-h,o-z)
17074       !      include 'DIMENSIONS'
17075 #ifdef MPI
17076             include 'mpif.h'
17077 #endif
17078       !      include 'COMMON.CHAIN'
17079       !      include 'COMMON.VAR'
17080       !      include 'COMMON.GEO'
17081       !      include 'COMMON.INTERACT'
17082       !      include 'COMMON.DERIV'
17083       !      include 'COMMON.IOUNITS'
17084       !      include 'COMMON.SETUP'
17085             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17086             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17087             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17088             real(kind=8),dimension(3) :: dc_norm_s
17089             real(kind=8) :: aincr=1.0d-5
17090             integer :: i,j
17091             real(kind=8) :: dcji
17092             do i=1,nres
17093             phi_s(i)=phi(i)
17094             theta_s(i)=theta(i)
17095             alph_s(i)=alph(i)
17096             omeg_s(i)=omeg(i)
17097             enddo
17098       ! Check theta gradient
17099             write (iout,*) &
17100              "Analytical (upper) and numerical (lower) gradient of theta"
17101             write (iout,*)
17102             do i=3,nres
17103             do j=1,3
17104               dcji=dc(j,i-2)
17105               dc(j,i-2)=dcji+aincr
17106               call chainbuild_cart
17107               call int_from_cart1(.false.)
17108           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17109           dc(j,i-2)=dcji
17110           dcji=dc(j,i-1)
17111           dc(j,i-1)=dc(j,i-1)+aincr
17112           call chainbuild_cart
17113           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17114           dc(j,i-1)=dcji
17115         enddo
17116 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17117 !el          (dtheta(j,2,i),j=1,3)
17118 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17119 !el          (dthetanum(j,2,i),j=1,3)
17120 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17121 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17122 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17123 !el        write (iout,*)
17124       enddo
17125 ! Check gamma gradient
17126       write (iout,*) &
17127        "Analytical (upper) and numerical (lower) gradient of gamma"
17128       do i=4,nres
17129         do j=1,3
17130           dcji=dc(j,i-3)
17131           dc(j,i-3)=dcji+aincr
17132           call chainbuild_cart
17133           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17134               dc(j,i-3)=dcji
17135           dcji=dc(j,i-2)
17136           dc(j,i-2)=dcji+aincr
17137           call chainbuild_cart
17138           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17139           dc(j,i-2)=dcji
17140           dcji=dc(j,i-1)
17141           dc(j,i-1)=dc(j,i-1)+aincr
17142           call chainbuild_cart
17143           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17144           dc(j,i-1)=dcji
17145         enddo
17146 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17147 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17148 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17149 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17150 !el        write (iout,'(5x,3(3f10.5,5x))') &
17151 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17152 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17153 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17154 !el        write (iout,*)
17155       enddo
17156 ! Check alpha gradient
17157       write (iout,*) &
17158        "Analytical (upper) and numerical (lower) gradient of alpha"
17159       do i=2,nres-1
17160        if(itype(i,1).ne.10) then
17161                  do j=1,3
17162                   dcji=dc(j,i-1)
17163                    dc(j,i-1)=dcji+aincr
17164               call chainbuild_cart
17165               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17166                  /aincr
17167                   dc(j,i-1)=dcji
17168               dcji=dc(j,i)
17169               dc(j,i)=dcji+aincr
17170               call chainbuild_cart
17171               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17172                  /aincr
17173               dc(j,i)=dcji
17174               dcji=dc(j,i+nres)
17175               dc(j,i+nres)=dc(j,i+nres)+aincr
17176               call chainbuild_cart
17177               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17178                  /aincr
17179              dc(j,i+nres)=dcji
17180             enddo
17181           endif
17182 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17183 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17184 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17185 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17186 !el        write (iout,'(5x,3(3f10.5,5x))') &
17187 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17188 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17189 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17190 !el        write (iout,*)
17191       enddo
17192 !     Check omega gradient
17193       write (iout,*) &
17194        "Analytical (upper) and numerical (lower) gradient of omega"
17195       do i=2,nres-1
17196        if(itype(i,1).ne.10) then
17197                  do j=1,3
17198                   dcji=dc(j,i-1)
17199                    dc(j,i-1)=dcji+aincr
17200               call chainbuild_cart
17201               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17202                  /aincr
17203                   dc(j,i-1)=dcji
17204               dcji=dc(j,i)
17205               dc(j,i)=dcji+aincr
17206               call chainbuild_cart
17207               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17208                  /aincr
17209               dc(j,i)=dcji
17210               dcji=dc(j,i+nres)
17211               dc(j,i+nres)=dc(j,i+nres)+aincr
17212               call chainbuild_cart
17213               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17214                  /aincr
17215              dc(j,i+nres)=dcji
17216             enddo
17217           endif
17218 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17219 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17220 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17221 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17222 !el        write (iout,'(5x,3(3f10.5,5x))') &
17223 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17224 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17225 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17226 !el        write (iout,*)
17227       enddo
17228       return
17229       end subroutine checkintcartgrad
17230 !-----------------------------------------------------------------------------
17231 ! q_measure.F
17232 !-----------------------------------------------------------------------------
17233       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17234 !      implicit real*8 (a-h,o-z)
17235 !      include 'DIMENSIONS'
17236 !      include 'COMMON.IOUNITS'
17237 !      include 'COMMON.CHAIN'
17238 !      include 'COMMON.INTERACT'
17239 !      include 'COMMON.VAR'
17240       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17241       integer :: kkk,nsep=3
17242       real(kind=8) :: qm      !dist,
17243       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17244       logical :: lprn=.false.
17245       logical :: flag
17246 !      real(kind=8) :: sigm,x
17247
17248 !el      sigm(x)=0.25d0*x     ! local function
17249       qqmax=1.0d10
17250       do kkk=1,nperm
17251       qq = 0.0d0
17252       nl=0
17253        if(flag) then
17254         do il=seg1+nsep,seg2
17255           do jl=seg1,il-nsep
17256             nl=nl+1
17257             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17258                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17259                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17260             dij=dist(il,jl)
17261             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17262             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17263               nl=nl+1
17264               d0ijCM=dsqrt( &
17265                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17266                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17267                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17268               dijCM=dist(il+nres,jl+nres)
17269               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17270             endif
17271             qq = qq+qqij+qqijCM
17272           enddo
17273         enddo
17274         qq = qq/nl
17275       else
17276       do il=seg1,seg2
17277         if((seg3-il).lt.3) then
17278              secseg=il+3
17279         else
17280              secseg=seg3
17281         endif
17282           do jl=secseg,seg4
17283             nl=nl+1
17284             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17285                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17286                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17287             dij=dist(il,jl)
17288             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17289             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17290               nl=nl+1
17291               d0ijCM=dsqrt( &
17292                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17293                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17294                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17295               dijCM=dist(il+nres,jl+nres)
17296               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17297             endif
17298             qq = qq+qqij+qqijCM
17299           enddo
17300         enddo
17301       qq = qq/nl
17302       endif
17303       if (qqmax.le.qq) qqmax=qq
17304       enddo
17305       qwolynes=1.0d0-qqmax
17306       return
17307       end function qwolynes
17308 !-----------------------------------------------------------------------------
17309       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17310 !      implicit real*8 (a-h,o-z)
17311 !      include 'DIMENSIONS'
17312 !      include 'COMMON.IOUNITS'
17313 !      include 'COMMON.CHAIN'
17314 !      include 'COMMON.INTERACT'
17315 !      include 'COMMON.VAR'
17316 !      include 'COMMON.MD'
17317       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17318       integer :: nsep=3, kkk
17319 !el      real(kind=8) :: dist
17320       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17321       logical :: lprn=.false.
17322       logical :: flag
17323       real(kind=8) :: sim,dd0,fac,ddqij
17324 !el      sigm(x)=0.25d0*x           ! local function
17325       do kkk=1,nperm
17326       do i=0,nres
17327         do j=1,3
17328           dqwol(j,i)=0.0d0
17329           dxqwol(j,i)=0.0d0
17330         enddo
17331       enddo
17332       nl=0
17333        if(flag) then
17334         do il=seg1+nsep,seg2
17335           do jl=seg1,il-nsep
17336             nl=nl+1
17337             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17338                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17339                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17340             dij=dist(il,jl)
17341             sim = 1.0d0/sigm(d0ij)
17342             sim = sim*sim
17343             dd0 = dij-d0ij
17344             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17345           do k=1,3
17346               ddqij = (c(k,il)-c(k,jl))*fac
17347               dqwol(k,il)=dqwol(k,il)+ddqij
17348               dqwol(k,jl)=dqwol(k,jl)-ddqij
17349             enddo
17350
17351             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17352               nl=nl+1
17353               d0ijCM=dsqrt( &
17354                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17355                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17356                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17357               dijCM=dist(il+nres,jl+nres)
17358               sim = 1.0d0/sigm(d0ijCM)
17359               sim = sim*sim
17360               dd0=dijCM-d0ijCM
17361               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17362               do k=1,3
17363                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17364                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17365                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17366               enddo
17367             endif
17368           enddo
17369         enddo
17370        else
17371         do il=seg1,seg2
17372         if((seg3-il).lt.3) then
17373              secseg=il+3
17374         else
17375              secseg=seg3
17376         endif
17377           do jl=secseg,seg4
17378             nl=nl+1
17379             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17380                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17381                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17382             dij=dist(il,jl)
17383             sim = 1.0d0/sigm(d0ij)
17384             sim = sim*sim
17385             dd0 = dij-d0ij
17386             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17387             do k=1,3
17388               ddqij = (c(k,il)-c(k,jl))*fac
17389               dqwol(k,il)=dqwol(k,il)+ddqij
17390               dqwol(k,jl)=dqwol(k,jl)-ddqij
17391             enddo
17392             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17393               nl=nl+1
17394               d0ijCM=dsqrt( &
17395                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17396                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17397                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17398               dijCM=dist(il+nres,jl+nres)
17399               sim = 1.0d0/sigm(d0ijCM)
17400               sim=sim*sim
17401               dd0 = dijCM-d0ijCM
17402               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17403               do k=1,3
17404                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17405                dxqwol(k,il)=dxqwol(k,il)+ddqij
17406                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17407               enddo
17408             endif
17409           enddo
17410         enddo
17411       endif
17412       enddo
17413        do i=0,nres
17414          do j=1,3
17415            dqwol(j,i)=dqwol(j,i)/nl
17416            dxqwol(j,i)=dxqwol(j,i)/nl
17417          enddo
17418        enddo
17419       return
17420       end subroutine qwolynes_prim
17421 !-----------------------------------------------------------------------------
17422       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17423 !      implicit real*8 (a-h,o-z)
17424 !      include 'DIMENSIONS'
17425 !      include 'COMMON.IOUNITS'
17426 !      include 'COMMON.CHAIN'
17427 !      include 'COMMON.INTERACT'
17428 !      include 'COMMON.VAR'
17429       integer :: seg1,seg2,seg3,seg4
17430       logical :: flag
17431       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17432       real(kind=8),dimension(3,0:2*nres) :: cdummy
17433       real(kind=8) :: q1,q2
17434       real(kind=8) :: delta=1.0d-10
17435       integer :: i,j
17436
17437       do i=0,nres
17438         do j=1,3
17439           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17440           cdummy(j,i)=c(j,i)
17441           c(j,i)=c(j,i)+delta
17442           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17443           qwolan(j,i)=(q2-q1)/delta
17444           c(j,i)=cdummy(j,i)
17445         enddo
17446       enddo
17447       do i=0,nres
17448         do j=1,3
17449           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17450           cdummy(j,i+nres)=c(j,i+nres)
17451           c(j,i+nres)=c(j,i+nres)+delta
17452           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17453           qwolxan(j,i)=(q2-q1)/delta
17454           c(j,i+nres)=cdummy(j,i+nres)
17455         enddo
17456       enddo
17457 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17458 !      do i=0,nct
17459 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17460 !      enddo
17461 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17462 !      do i=0,nct
17463 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17464 !      enddo
17465       return
17466       end subroutine qwol_num
17467 !-----------------------------------------------------------------------------
17468       subroutine EconstrQ
17469 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17470 !      implicit real*8 (a-h,o-z)
17471 !      include 'DIMENSIONS'
17472 !      include 'COMMON.CONTROL'
17473 !      include 'COMMON.VAR'
17474 !      include 'COMMON.MD'
17475       use MD_data
17476 !#ifndef LANG0
17477 !      include 'COMMON.LANGEVIN'
17478 !#else
17479 !      include 'COMMON.LANGEVIN.lang0'
17480 !#endif
17481 !      include 'COMMON.CHAIN'
17482 !      include 'COMMON.DERIV'
17483 !      include 'COMMON.GEO'
17484 !      include 'COMMON.LOCAL'
17485 !      include 'COMMON.INTERACT'
17486 !      include 'COMMON.IOUNITS'
17487 !      include 'COMMON.NAMES'
17488 !      include 'COMMON.TIME1'
17489       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17490       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17491                    duconst,duxconst
17492       integer :: kstart,kend,lstart,lend,idummy
17493       real(kind=8) :: delta=1.0d-7
17494       integer :: i,j,k,ii
17495       do i=0,nres
17496          do j=1,3
17497             duconst(j,i)=0.0d0
17498             dudconst(j,i)=0.0d0
17499             duxconst(j,i)=0.0d0
17500             dudxconst(j,i)=0.0d0
17501          enddo
17502       enddo
17503       Uconst=0.0d0
17504       do i=1,nfrag
17505          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17506            idummy,idummy)
17507          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17508 ! Calculating the derivatives of Constraint energy with respect to Q
17509          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17510            qinfrag(i,iset))
17511 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17512 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17513 !         hmnum=(hm2-hm1)/delta
17514 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17515 !     &   qinfrag(i,iset))
17516 !         write(iout,*) "harmonicnum frag", hmnum
17517 ! Calculating the derivatives of Q with respect to cartesian coordinates
17518          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17519           idummy,idummy)
17520 !         write(iout,*) "dqwol "
17521 !         do ii=1,nres
17522 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17523 !         enddo
17524 !         write(iout,*) "dxqwol "
17525 !         do ii=1,nres
17526 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17527 !         enddo
17528 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17529 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17530 !     &  ,idummy,idummy)
17531 !  The gradients of Uconst in Cs
17532          do ii=0,nres
17533             do j=1,3
17534                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17535                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17536             enddo
17537          enddo
17538       enddo
17539       do i=1,npair
17540          kstart=ifrag(1,ipair(1,i,iset),iset)
17541          kend=ifrag(2,ipair(1,i,iset),iset)
17542          lstart=ifrag(1,ipair(2,i,iset),iset)
17543          lend=ifrag(2,ipair(2,i,iset),iset)
17544          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17545          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17546 !  Calculating dU/dQ
17547          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17548 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17549 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17550 !         hmnum=(hm2-hm1)/delta
17551 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17552 !     &   qinpair(i,iset))
17553 !         write(iout,*) "harmonicnum pair ", hmnum
17554 ! Calculating dQ/dXi
17555          call qwolynes_prim(kstart,kend,.false.,&
17556           lstart,lend)
17557 !         write(iout,*) "dqwol "
17558 !         do ii=1,nres
17559 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17560 !         enddo
17561 !         write(iout,*) "dxqwol "
17562 !         do ii=1,nres
17563 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17564 !        enddo
17565 ! Calculating numerical gradients
17566 !        call qwol_num(kstart,kend,.false.
17567 !     &  ,lstart,lend)
17568 ! The gradients of Uconst in Cs
17569          do ii=0,nres
17570             do j=1,3
17571                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17572                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17573             enddo
17574          enddo
17575       enddo
17576 !      write(iout,*) "Uconst inside subroutine ", Uconst
17577 ! Transforming the gradients from Cs to dCs for the backbone
17578       do i=0,nres
17579          do j=i+1,nres
17580            do k=1,3
17581              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17582            enddo
17583          enddo
17584       enddo
17585 !  Transforming the gradients from Cs to dCs for the side chains
17586       do i=1,nres
17587          do j=1,3
17588            dudxconst(j,i)=duxconst(j,i)
17589          enddo
17590       enddo
17591 !      write(iout,*) "dU/ddc backbone "
17592 !       do ii=0,nres
17593 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17594 !      enddo
17595 !      write(iout,*) "dU/ddX side chain "
17596 !      do ii=1,nres
17597 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17598 !      enddo
17599 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17600 !      call dEconstrQ_num
17601       return
17602       end subroutine EconstrQ
17603 !-----------------------------------------------------------------------------
17604       subroutine dEconstrQ_num
17605 ! Calculating numerical dUconst/ddc and dUconst/ddx
17606 !      implicit real*8 (a-h,o-z)
17607 !      include 'DIMENSIONS'
17608 !      include 'COMMON.CONTROL'
17609 !      include 'COMMON.VAR'
17610 !      include 'COMMON.MD'
17611       use MD_data
17612 !#ifndef LANG0
17613 !      include 'COMMON.LANGEVIN'
17614 !#else
17615 !      include 'COMMON.LANGEVIN.lang0'
17616 !#endif
17617 !      include 'COMMON.CHAIN'
17618 !      include 'COMMON.DERIV'
17619 !      include 'COMMON.GEO'
17620 !      include 'COMMON.LOCAL'
17621 !      include 'COMMON.INTERACT'
17622 !      include 'COMMON.IOUNITS'
17623 !      include 'COMMON.NAMES'
17624 !      include 'COMMON.TIME1'
17625       real(kind=8) :: uzap1,uzap2
17626       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17627       integer :: kstart,kend,lstart,lend,idummy
17628       real(kind=8) :: delta=1.0d-7
17629 !el local variables
17630       integer :: i,ii,j
17631 !     real(kind=8) ::
17632 !     For the backbone
17633       do i=0,nres-1
17634          do j=1,3
17635             dUcartan(j,i)=0.0d0
17636             cdummy(j,i)=dc(j,i)
17637             dc(j,i)=dc(j,i)+delta
17638             call chainbuild_cart
17639           uzap2=0.0d0
17640             do ii=1,nfrag
17641              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17642                 idummy,idummy)
17643                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17644                 qinfrag(ii,iset))
17645             enddo
17646             do ii=1,npair
17647                kstart=ifrag(1,ipair(1,ii,iset),iset)
17648                kend=ifrag(2,ipair(1,ii,iset),iset)
17649                lstart=ifrag(1,ipair(2,ii,iset),iset)
17650                lend=ifrag(2,ipair(2,ii,iset),iset)
17651                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17652                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17653                  qinpair(ii,iset))
17654             enddo
17655             dc(j,i)=cdummy(j,i)
17656             call chainbuild_cart
17657             uzap1=0.0d0
17658              do ii=1,nfrag
17659              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17660                 idummy,idummy)
17661                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17662                 qinfrag(ii,iset))
17663             enddo
17664             do ii=1,npair
17665                kstart=ifrag(1,ipair(1,ii,iset),iset)
17666                kend=ifrag(2,ipair(1,ii,iset),iset)
17667                lstart=ifrag(1,ipair(2,ii,iset),iset)
17668                lend=ifrag(2,ipair(2,ii,iset),iset)
17669                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17670                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17671                 qinpair(ii,iset))
17672             enddo
17673             ducartan(j,i)=(uzap2-uzap1)/(delta)
17674          enddo
17675       enddo
17676 ! Calculating numerical gradients for dU/ddx
17677       do i=0,nres-1
17678          duxcartan(j,i)=0.0d0
17679          do j=1,3
17680             cdummy(j,i)=dc(j,i+nres)
17681             dc(j,i+nres)=dc(j,i+nres)+delta
17682             call chainbuild_cart
17683           uzap2=0.0d0
17684             do ii=1,nfrag
17685              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17686                 idummy,idummy)
17687                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17688                 qinfrag(ii,iset))
17689             enddo
17690             do ii=1,npair
17691                kstart=ifrag(1,ipair(1,ii,iset),iset)
17692                kend=ifrag(2,ipair(1,ii,iset),iset)
17693                lstart=ifrag(1,ipair(2,ii,iset),iset)
17694                lend=ifrag(2,ipair(2,ii,iset),iset)
17695                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17696                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17697                 qinpair(ii,iset))
17698             enddo
17699             dc(j,i+nres)=cdummy(j,i)
17700             call chainbuild_cart
17701             uzap1=0.0d0
17702              do ii=1,nfrag
17703                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17704                 ifrag(2,ii,iset),.true.,idummy,idummy)
17705                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17706                 qinfrag(ii,iset))
17707             enddo
17708             do ii=1,npair
17709                kstart=ifrag(1,ipair(1,ii,iset),iset)
17710                kend=ifrag(2,ipair(1,ii,iset),iset)
17711                lstart=ifrag(1,ipair(2,ii,iset),iset)
17712                lend=ifrag(2,ipair(2,ii,iset),iset)
17713                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17714                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17715                 qinpair(ii,iset))
17716             enddo
17717             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17718          enddo
17719       enddo
17720       write(iout,*) "Numerical dUconst/ddc backbone "
17721       do ii=0,nres
17722         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17723       enddo
17724 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17725 !      do ii=1,nres
17726 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17727 !      enddo
17728       return
17729       end subroutine dEconstrQ_num
17730 !-----------------------------------------------------------------------------
17731 ! ssMD.F
17732 !-----------------------------------------------------------------------------
17733       subroutine check_energies
17734
17735 !      use random, only: ran_number
17736
17737 !      implicit none
17738 !     Includes
17739 !      include 'DIMENSIONS'
17740 !      include 'COMMON.CHAIN'
17741 !      include 'COMMON.VAR'
17742 !      include 'COMMON.IOUNITS'
17743 !      include 'COMMON.SBRIDGE'
17744 !      include 'COMMON.LOCAL'
17745 !      include 'COMMON.GEO'
17746
17747 !     External functions
17748 !EL      double precision ran_number
17749 !EL      external ran_number
17750
17751 !     Local variables
17752       integer :: i,j,k,l,lmax,p,pmax
17753       real(kind=8) :: rmin,rmax
17754       real(kind=8) :: eij
17755
17756       real(kind=8) :: d
17757       real(kind=8) :: wi,rij,tj,pj
17758 !      return
17759
17760       i=5
17761       j=14
17762
17763       d=dsc(1)
17764       rmin=2.0D0
17765       rmax=12.0D0
17766
17767       lmax=10000
17768       pmax=1
17769
17770       do k=1,3
17771         c(k,i)=0.0D0
17772         c(k,j)=0.0D0
17773         c(k,nres+i)=0.0D0
17774         c(k,nres+j)=0.0D0
17775       enddo
17776
17777       do l=1,lmax
17778
17779 !t        wi=ran_number(0.0D0,pi)
17780 !        wi=ran_number(0.0D0,pi/6.0D0)
17781 !        wi=0.0D0
17782 !t        tj=ran_number(0.0D0,pi)
17783 !t        pj=ran_number(0.0D0,pi)
17784 !        pj=ran_number(0.0D0,pi/6.0D0)
17785 !        pj=0.0D0
17786
17787         do p=1,pmax
17788 !t           rij=ran_number(rmin,rmax)
17789
17790            c(1,j)=d*sin(pj)*cos(tj)
17791            c(2,j)=d*sin(pj)*sin(tj)
17792            c(3,j)=d*cos(pj)
17793
17794            c(3,nres+i)=-rij
17795
17796            c(1,i)=d*sin(wi)
17797            c(3,i)=-rij-d*cos(wi)
17798
17799            do k=1,3
17800               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17801               dc_norm(k,nres+i)=dc(k,nres+i)/d
17802               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17803               dc_norm(k,nres+j)=dc(k,nres+j)/d
17804            enddo
17805
17806            call dyn_ssbond_ene(i,j,eij)
17807         enddo
17808       enddo
17809       call exit(1)
17810       return
17811       end subroutine check_energies
17812 !-----------------------------------------------------------------------------
17813       subroutine dyn_ssbond_ene(resi,resj,eij)
17814 !      implicit none
17815 !      Includes
17816       use calc_data
17817       use comm_sschecks
17818 !      include 'DIMENSIONS'
17819 !      include 'COMMON.SBRIDGE'
17820 !      include 'COMMON.CHAIN'
17821 !      include 'COMMON.DERIV'
17822 !      include 'COMMON.LOCAL'
17823 !      include 'COMMON.INTERACT'
17824 !      include 'COMMON.VAR'
17825 !      include 'COMMON.IOUNITS'
17826 !      include 'COMMON.CALC'
17827 #ifndef CLUST
17828 #ifndef WHAM
17829        use MD_data
17830 !      include 'COMMON.MD'
17831 !      use MD, only: totT,t_bath
17832 #endif
17833 #endif
17834 !     External functions
17835 !EL      double precision h_base
17836 !EL      external h_base
17837
17838 !     Input arguments
17839       integer :: resi,resj
17840
17841 !     Output arguments
17842       real(kind=8) :: eij
17843
17844 !     Local variables
17845       logical :: havebond
17846       integer itypi,itypj
17847       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17848       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17849       real(kind=8),dimension(3) :: dcosom1,dcosom2
17850       real(kind=8) :: ed
17851       real(kind=8) :: pom1,pom2
17852       real(kind=8) :: ljA,ljB,ljXs
17853       real(kind=8),dimension(1:3) :: d_ljB
17854       real(kind=8) :: ssA,ssB,ssC,ssXs
17855       real(kind=8) :: ssxm,ljxm,ssm,ljm
17856       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17857       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17858       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17859 !-------FIRST METHOD
17860       real(kind=8) :: xm
17861       real(kind=8),dimension(1:3) :: d_xm
17862 !-------END FIRST METHOD
17863 !-------SECOND METHOD
17864 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17865 !-------END SECOND METHOD
17866
17867 !-------TESTING CODE
17868 !el      logical :: checkstop,transgrad
17869 !el      common /sschecks/ checkstop,transgrad
17870
17871       integer :: icheck,nicheck,jcheck,njcheck
17872       real(kind=8),dimension(-1:1) :: echeck
17873       real(kind=8) :: deps,ssx0,ljx0
17874 !-------END TESTING CODE
17875
17876       eij=0.0d0
17877       i=resi
17878       j=resj
17879
17880 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17881 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17882
17883       itypi=itype(i,1)
17884       dxi=dc_norm(1,nres+i)
17885       dyi=dc_norm(2,nres+i)
17886       dzi=dc_norm(3,nres+i)
17887       dsci_inv=vbld_inv(i+nres)
17888
17889       itypj=itype(j,1)
17890       xj=c(1,nres+j)-c(1,nres+i)
17891       yj=c(2,nres+j)-c(2,nres+i)
17892       zj=c(3,nres+j)-c(3,nres+i)
17893       dxj=dc_norm(1,nres+j)
17894       dyj=dc_norm(2,nres+j)
17895       dzj=dc_norm(3,nres+j)
17896       dscj_inv=vbld_inv(j+nres)
17897
17898       chi1=chi(itypi,itypj)
17899       chi2=chi(itypj,itypi)
17900       chi12=chi1*chi2
17901       chip1=chip(itypi)
17902       chip2=chip(itypj)
17903       chip12=chip1*chip2
17904       alf1=alp(itypi)
17905       alf2=alp(itypj)
17906       alf12=0.5D0*(alf1+alf2)
17907
17908       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17909       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17910 !     The following are set in sc_angular
17911 !      erij(1)=xj*rij
17912 !      erij(2)=yj*rij
17913 !      erij(3)=zj*rij
17914 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17915 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17916 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17917       call sc_angular
17918       rij=1.0D0/rij  ! Reset this so it makes sense
17919
17920       sig0ij=sigma(itypi,itypj)
17921       sig=sig0ij*dsqrt(1.0D0/sigsq)
17922
17923       ljXs=sig-sig0ij
17924       ljA=eps1*eps2rt**2*eps3rt**2
17925       ljB=ljA*bb_aq(itypi,itypj)
17926       ljA=ljA*aa_aq(itypi,itypj)
17927       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17928
17929       ssXs=d0cm
17930       deltat1=1.0d0-om1
17931       deltat2=1.0d0+om2
17932       deltat12=om2-om1+2.0d0
17933       cosphi=om12-om1*om2
17934       ssA=akcm
17935       ssB=akct*deltat12
17936       ssC=ss_depth &
17937            +akth*(deltat1*deltat1+deltat2*deltat2) &
17938            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17939       ssxm=ssXs-0.5D0*ssB/ssA
17940
17941 !-------TESTING CODE
17942 !$$$c     Some extra output
17943 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17944 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17945 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17946 !$$$      if (ssx0.gt.0.0d0) then
17947 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17948 !$$$      else
17949 !$$$        ssx0=ssxm
17950 !$$$      endif
17951 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17952 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17953 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17954 !$$$      return
17955 !-------END TESTING CODE
17956
17957 !-------TESTING CODE
17958 !     Stop and plot energy and derivative as a function of distance
17959       if (checkstop) then
17960         ssm=ssC-0.25D0*ssB*ssB/ssA
17961         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17962         if (ssm.lt.ljm .and. &
17963              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17964           nicheck=1000
17965           njcheck=1
17966           deps=0.5d-7
17967         else
17968           checkstop=.false.
17969         endif
17970       endif
17971       if (.not.checkstop) then
17972         nicheck=0
17973         njcheck=-1
17974       endif
17975
17976       do icheck=0,nicheck
17977       do jcheck=-1,njcheck
17978       if (checkstop) rij=(ssxm-1.0d0)+ &
17979              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17980 !-------END TESTING CODE
17981
17982       if (rij.gt.ljxm) then
17983         havebond=.false.
17984         ljd=rij-ljXs
17985         fac=(1.0D0/ljd)**expon
17986         e1=fac*fac*aa_aq(itypi,itypj)
17987         e2=fac*bb_aq(itypi,itypj)
17988         eij=eps1*eps2rt*eps3rt*(e1+e2)
17989         eps2der=eij*eps3rt
17990         eps3der=eij*eps2rt
17991         eij=eij*eps2rt*eps3rt
17992
17993         sigder=-sig/sigsq
17994         e1=e1*eps1*eps2rt**2*eps3rt**2
17995         ed=-expon*(e1+eij)/ljd
17996         sigder=ed*sigder
17997         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17998         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17999         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18000              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18001       else if (rij.lt.ssxm) then
18002         havebond=.true.
18003         ssd=rij-ssXs
18004         eij=ssA*ssd*ssd+ssB*ssd+ssC
18005
18006         ed=2*akcm*ssd+akct*deltat12
18007         pom1=akct*ssd
18008         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18009         eom1=-2*akth*deltat1-pom1-om2*pom2
18010         eom2= 2*akth*deltat2+pom1-om1*pom2
18011         eom12=pom2
18012       else
18013         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18014
18015         d_ssxm(1)=0.5D0*akct/ssA
18016         d_ssxm(2)=-d_ssxm(1)
18017         d_ssxm(3)=0.0D0
18018
18019         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18020         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18021         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18022         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18023
18024 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18025         xm=0.5d0*(ssxm+ljxm)
18026         do k=1,3
18027           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18028         enddo
18029         if (rij.lt.xm) then
18030           havebond=.true.
18031           ssm=ssC-0.25D0*ssB*ssB/ssA
18032           d_ssm(1)=0.5D0*akct*ssB/ssA
18033           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18034           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18035           d_ssm(3)=omega
18036           f1=(rij-xm)/(ssxm-xm)
18037           f2=(rij-ssxm)/(xm-ssxm)
18038           h1=h_base(f1,hd1)
18039           h2=h_base(f2,hd2)
18040           eij=ssm*h1+Ht*h2
18041           delta_inv=1.0d0/(xm-ssxm)
18042           deltasq_inv=delta_inv*delta_inv
18043           fac=ssm*hd1-Ht*hd2
18044           fac1=deltasq_inv*fac*(xm-rij)
18045           fac2=deltasq_inv*fac*(rij-ssxm)
18046           ed=delta_inv*(Ht*hd2-ssm*hd1)
18047           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18048           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18049           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18050         else
18051           havebond=.false.
18052           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18053           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18054           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18055           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18056                alf12/eps3rt)
18057           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18058           f1=(rij-ljxm)/(xm-ljxm)
18059           f2=(rij-xm)/(ljxm-xm)
18060           h1=h_base(f1,hd1)
18061           h2=h_base(f2,hd2)
18062           eij=Ht*h1+ljm*h2
18063           delta_inv=1.0d0/(ljxm-xm)
18064           deltasq_inv=delta_inv*delta_inv
18065           fac=Ht*hd1-ljm*hd2
18066           fac1=deltasq_inv*fac*(ljxm-rij)
18067           fac2=deltasq_inv*fac*(rij-xm)
18068           ed=delta_inv*(ljm*hd2-Ht*hd1)
18069           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18070           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18071           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18072         endif
18073 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18074
18075 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18076 !$$$        ssd=rij-ssXs
18077 !$$$        ljd=rij-ljXs
18078 !$$$        fac1=rij-ljxm
18079 !$$$        fac2=rij-ssxm
18080 !$$$
18081 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18082 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18083 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18084 !$$$
18085 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18086 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18087 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18088 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18089 !$$$        d_ssm(3)=omega
18090 !$$$
18091 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18092 !$$$        do k=1,3
18093 !$$$          d_ljm(k)=ljm*d_ljB(k)
18094 !$$$        enddo
18095 !$$$        ljm=ljm*ljB
18096 !$$$
18097 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18098 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18099 !$$$        d_ss(2)=akct*ssd
18100 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18101 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18102 !$$$        d_ss(3)=omega
18103 !$$$
18104 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18105 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18106 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18107 !$$$        do k=1,3
18108 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18109 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18110 !$$$        enddo
18111 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18112 !$$$
18113 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18114 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18115 !$$$        h1=h_base(f1,hd1)
18116 !$$$        h2=h_base(f2,hd2)
18117 !$$$        eij=ss*h1+ljf*h2
18118 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18119 !$$$        deltasq_inv=delta_inv*delta_inv
18120 !$$$        fac=ljf*hd2-ss*hd1
18121 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18122 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18123 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18124 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18125 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18126 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18127 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18128 !$$$
18129 !$$$        havebond=.false.
18130 !$$$        if (ed.gt.0.0d0) havebond=.true.
18131 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18132
18133       endif
18134
18135       if (havebond) then
18136 !#ifndef CLUST
18137 !#ifndef WHAM
18138 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18139 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18140 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18141 !        endif
18142 !#endif
18143 !#endif
18144         dyn_ssbond_ij(i,j)=eij
18145       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18146         dyn_ssbond_ij(i,j)=1.0d300
18147 !#ifndef CLUST
18148 !#ifndef WHAM
18149 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18150 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18151 !#endif
18152 !#endif
18153       endif
18154
18155 !-------TESTING CODE
18156 !el      if (checkstop) then
18157         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18158              "CHECKSTOP",rij,eij,ed
18159         echeck(jcheck)=eij
18160 !el      endif
18161       enddo
18162       if (checkstop) then
18163         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18164       endif
18165       enddo
18166       if (checkstop) then
18167         transgrad=.true.
18168         checkstop=.false.
18169       endif
18170 !-------END TESTING CODE
18171
18172       do k=1,3
18173         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18174         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18175       enddo
18176       do k=1,3
18177         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18178       enddo
18179       do k=1,3
18180         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18181              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18182              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18183         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18184              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18185              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18186       enddo
18187 !grad      do k=i,j-1
18188 !grad        do l=1,3
18189 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18190 !grad        enddo
18191 !grad      enddo
18192
18193       do l=1,3
18194         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18195         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18196       enddo
18197
18198       return
18199       end subroutine dyn_ssbond_ene
18200 !--------------------------------------------------------------------------
18201          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18202 !      implicit none
18203 !      Includes
18204       use calc_data
18205       use comm_sschecks
18206 !      include 'DIMENSIONS'
18207 !      include 'COMMON.SBRIDGE'
18208 !      include 'COMMON.CHAIN'
18209 !      include 'COMMON.DERIV'
18210 !      include 'COMMON.LOCAL'
18211 !      include 'COMMON.INTERACT'
18212 !      include 'COMMON.VAR'
18213 !      include 'COMMON.IOUNITS'
18214 !      include 'COMMON.CALC'
18215 #ifndef CLUST
18216 #ifndef WHAM
18217        use MD_data
18218 !      include 'COMMON.MD'
18219 !      use MD, only: totT,t_bath
18220 #endif
18221 #endif
18222       double precision h_base
18223       external h_base
18224
18225 !c     Input arguments
18226       integer resi,resj,resk,m,itypi,itypj,itypk
18227
18228 !c     Output arguments
18229       double precision eij,eij1,eij2,eij3
18230
18231 !c     Local variables
18232       logical havebond
18233 !c      integer itypi,itypj,k,l
18234       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18235       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18236       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18237       double precision sig0ij,ljd,sig,fac,e1,e2
18238       double precision dcosom1(3),dcosom2(3),ed
18239       double precision pom1,pom2
18240       double precision ljA,ljB,ljXs
18241       double precision d_ljB(1:3)
18242       double precision ssA,ssB,ssC,ssXs
18243       double precision ssxm,ljxm,ssm,ljm
18244       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18245       eij=0.0
18246       if (dtriss.eq.0) return
18247       i=resi
18248       j=resj
18249       k=resk
18250 !C      write(iout,*) resi,resj,resk
18251       itypi=itype(i,1)
18252       dxi=dc_norm(1,nres+i)
18253       dyi=dc_norm(2,nres+i)
18254       dzi=dc_norm(3,nres+i)
18255       dsci_inv=vbld_inv(i+nres)
18256       xi=c(1,nres+i)
18257       yi=c(2,nres+i)
18258       zi=c(3,nres+i)
18259       itypj=itype(j,1)
18260       xj=c(1,nres+j)
18261       yj=c(2,nres+j)
18262       zj=c(3,nres+j)
18263
18264       dxj=dc_norm(1,nres+j)
18265       dyj=dc_norm(2,nres+j)
18266       dzj=dc_norm(3,nres+j)
18267       dscj_inv=vbld_inv(j+nres)
18268       itypk=itype(k,1)
18269       xk=c(1,nres+k)
18270       yk=c(2,nres+k)
18271       zk=c(3,nres+k)
18272
18273       dxk=dc_norm(1,nres+k)
18274       dyk=dc_norm(2,nres+k)
18275       dzk=dc_norm(3,nres+k)
18276       dscj_inv=vbld_inv(k+nres)
18277       xij=xj-xi
18278       xik=xk-xi
18279       xjk=xk-xj
18280       yij=yj-yi
18281       yik=yk-yi
18282       yjk=yk-yj
18283       zij=zj-zi
18284       zik=zk-zi
18285       zjk=zk-zj
18286       rrij=(xij*xij+yij*yij+zij*zij)
18287       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18288       rrik=(xik*xik+yik*yik+zik*zik)
18289       rik=dsqrt(rrik)
18290       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18291       rjk=dsqrt(rrjk)
18292 !C there are three combination of distances for each trisulfide bonds
18293 !C The first case the ith atom is the center
18294 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18295 !C distance y is second distance the a,b,c,d are parameters derived for
18296 !C this problem d parameter was set as a penalty currenlty set to 1.
18297       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18298       eij1=0.0d0
18299       else
18300       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18301       endif
18302 !C second case jth atom is center
18303       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18304       eij2=0.0d0
18305       else
18306       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18307       endif
18308 !C the third case kth atom is the center
18309       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18310       eij3=0.0d0
18311       else
18312       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18313       endif
18314 !C      eij2=0.0
18315 !C      eij3=0.0
18316 !C      eij1=0.0
18317       eij=eij1+eij2+eij3
18318 !C      write(iout,*)i,j,k,eij
18319 !C The energy penalty calculated now time for the gradient part
18320 !C derivative over rij
18321       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18322       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18323             gg(1)=xij*fac/rij
18324             gg(2)=yij*fac/rij
18325             gg(3)=zij*fac/rij
18326       do m=1,3
18327         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18328         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18329       enddo
18330
18331       do l=1,3
18332         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18333         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18334       enddo
18335 !C now derivative over rik
18336       fac=-eij1**2/dtriss* &
18337       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18338       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18339             gg(1)=xik*fac/rik
18340             gg(2)=yik*fac/rik
18341             gg(3)=zik*fac/rik
18342       do m=1,3
18343         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18344         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18345       enddo
18346       do l=1,3
18347         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18348         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18349       enddo
18350 !C now derivative over rjk
18351       fac=-eij2**2/dtriss* &
18352       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18353       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18354             gg(1)=xjk*fac/rjk
18355             gg(2)=yjk*fac/rjk
18356             gg(3)=zjk*fac/rjk
18357       do m=1,3
18358         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18359         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18360       enddo
18361       do l=1,3
18362         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18363         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18364       enddo
18365       return
18366       end subroutine triple_ssbond_ene
18367
18368
18369
18370 !-----------------------------------------------------------------------------
18371       real(kind=8) function h_base(x,deriv)
18372 !     A smooth function going 0->1 in range [0,1]
18373 !     It should NOT be called outside range [0,1], it will not work there.
18374       implicit none
18375
18376 !     Input arguments
18377       real(kind=8) :: x
18378
18379 !     Output arguments
18380       real(kind=8) :: deriv
18381
18382 !     Local variables
18383       real(kind=8) :: xsq
18384
18385
18386 !     Two parabolas put together.  First derivative zero at extrema
18387 !$$$      if (x.lt.0.5D0) then
18388 !$$$        h_base=2.0D0*x*x
18389 !$$$        deriv=4.0D0*x
18390 !$$$      else
18391 !$$$        deriv=1.0D0-x
18392 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18393 !$$$        deriv=4.0D0*deriv
18394 !$$$      endif
18395
18396 !     Third degree polynomial.  First derivative zero at extrema
18397       h_base=x*x*(3.0d0-2.0d0*x)
18398       deriv=6.0d0*x*(1.0d0-x)
18399
18400 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18401 !$$$      xsq=x*x
18402 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18403 !$$$      deriv=x-1.0d0
18404 !$$$      deriv=deriv*deriv
18405 !$$$      deriv=30.0d0*xsq*deriv
18406
18407       return
18408       end function h_base
18409 !-----------------------------------------------------------------------------
18410       subroutine dyn_set_nss
18411 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18412 !      implicit none
18413       use MD_data, only: totT,t_bath
18414 !     Includes
18415 !      include 'DIMENSIONS'
18416 #ifdef MPI
18417       include "mpif.h"
18418 #endif
18419 !      include 'COMMON.SBRIDGE'
18420 !      include 'COMMON.CHAIN'
18421 !      include 'COMMON.IOUNITS'
18422 !      include 'COMMON.SETUP'
18423 !      include 'COMMON.MD'
18424 !     Local variables
18425       real(kind=8) :: emin
18426       integer :: i,j,imin,ierr
18427       integer :: diff,allnss,newnss
18428       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18429                 newihpb,newjhpb
18430       logical :: found
18431       integer,dimension(0:nfgtasks) :: i_newnss
18432       integer,dimension(0:nfgtasks) :: displ
18433       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18434       integer :: g_newnss
18435
18436       allnss=0
18437       do i=1,nres-1
18438         do j=i+1,nres
18439           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18440             allnss=allnss+1
18441             allflag(allnss)=0
18442             allihpb(allnss)=i
18443             alljhpb(allnss)=j
18444           endif
18445         enddo
18446       enddo
18447
18448 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18449
18450  1    emin=1.0d300
18451       do i=1,allnss
18452         if (allflag(i).eq.0 .and. &
18453              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18454           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18455           imin=i
18456         endif
18457       enddo
18458       if (emin.lt.1.0d300) then
18459         allflag(imin)=1
18460         do i=1,allnss
18461           if (allflag(i).eq.0 .and. &
18462                (allihpb(i).eq.allihpb(imin) .or. &
18463                alljhpb(i).eq.allihpb(imin) .or. &
18464                allihpb(i).eq.alljhpb(imin) .or. &
18465                alljhpb(i).eq.alljhpb(imin))) then
18466             allflag(i)=-1
18467           endif
18468         enddo
18469         goto 1
18470       endif
18471
18472 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18473
18474       newnss=0
18475       do i=1,allnss
18476         if (allflag(i).eq.1) then
18477           newnss=newnss+1
18478           newihpb(newnss)=allihpb(i)
18479           newjhpb(newnss)=alljhpb(i)
18480         endif
18481       enddo
18482
18483 #ifdef MPI
18484       if (nfgtasks.gt.1)then
18485
18486         call MPI_Reduce(newnss,g_newnss,1,&
18487           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18488         call MPI_Gather(newnss,1,MPI_INTEGER,&
18489                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18490         displ(0)=0
18491         do i=1,nfgtasks-1,1
18492           displ(i)=i_newnss(i-1)+displ(i-1)
18493         enddo
18494         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18495                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18496                          king,FG_COMM,IERR)
18497         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18498                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18499                          king,FG_COMM,IERR)
18500         if(fg_rank.eq.0) then
18501 !         print *,'g_newnss',g_newnss
18502 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18503 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18504          newnss=g_newnss
18505          do i=1,newnss
18506           newihpb(i)=g_newihpb(i)
18507           newjhpb(i)=g_newjhpb(i)
18508          enddo
18509         endif
18510       endif
18511 #endif
18512
18513       diff=newnss-nss
18514
18515 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18516 !       print *,newnss,nss,maxdim
18517       do i=1,nss
18518         found=.false.
18519 !        print *,newnss
18520         do j=1,newnss
18521 !!          print *,j
18522           if (idssb(i).eq.newihpb(j) .and. &
18523                jdssb(i).eq.newjhpb(j)) found=.true.
18524         enddo
18525 #ifndef CLUST
18526 #ifndef WHAM
18527 !        write(iout,*) "found",found,i,j
18528         if (.not.found.and.fg_rank.eq.0) &
18529             write(iout,'(a15,f12.2,f8.1,2i5)') &
18530              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18531 #endif
18532 #endif
18533       enddo
18534
18535       do i=1,newnss
18536         found=.false.
18537         do j=1,nss
18538 !          print *,i,j
18539           if (newihpb(i).eq.idssb(j) .and. &
18540                newjhpb(i).eq.jdssb(j)) found=.true.
18541         enddo
18542 #ifndef CLUST
18543 #ifndef WHAM
18544 !        write(iout,*) "found",found,i,j
18545         if (.not.found.and.fg_rank.eq.0) &
18546             write(iout,'(a15,f12.2,f8.1,2i5)') &
18547              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18548 #endif
18549 #endif
18550       enddo
18551
18552       nss=newnss
18553       do i=1,nss
18554         idssb(i)=newihpb(i)
18555         jdssb(i)=newjhpb(i)
18556       enddo
18557
18558       return
18559       end subroutine dyn_set_nss
18560 ! Lipid transfer energy function
18561       subroutine Eliptransfer(eliptran)
18562 !C this is done by Adasko
18563 !C      print *,"wchodze"
18564 !C structure of box:
18565 !C      water
18566 !C--bordliptop-- buffore starts
18567 !C--bufliptop--- here true lipid starts
18568 !C      lipid
18569 !C--buflipbot--- lipid ends buffore starts
18570 !C--bordlipbot--buffore ends
18571       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18572       integer :: i
18573       eliptran=0.0
18574 !      print *, "I am in eliptran"
18575       do i=ilip_start,ilip_end
18576 !C       do i=1,1
18577         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18578          cycle
18579
18580         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18581         if (positi.le.0.0) positi=positi+boxzsize
18582 !C        print *,i
18583 !C first for peptide groups
18584 !c for each residue check if it is in lipid or lipid water border area
18585        if ((positi.gt.bordlipbot)  &
18586       .and.(positi.lt.bordliptop)) then
18587 !C the energy transfer exist
18588         if (positi.lt.buflipbot) then
18589 !C what fraction I am in
18590          fracinbuf=1.0d0-      &
18591              ((positi-bordlipbot)/lipbufthick)
18592 !C lipbufthick is thickenes of lipid buffore
18593          sslip=sscalelip(fracinbuf)
18594          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18595          eliptran=eliptran+sslip*pepliptran
18596          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18597          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18598 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18599
18600 !C        print *,"doing sccale for lower part"
18601 !C         print *,i,sslip,fracinbuf,ssgradlip
18602         elseif (positi.gt.bufliptop) then
18603          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18604          sslip=sscalelip(fracinbuf)
18605          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18606          eliptran=eliptran+sslip*pepliptran
18607          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18608          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18609 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18610 !C          print *, "doing sscalefor top part"
18611 !C         print *,i,sslip,fracinbuf,ssgradlip
18612         else
18613          eliptran=eliptran+pepliptran
18614 !C         print *,"I am in true lipid"
18615         endif
18616 !C       else
18617 !C       eliptran=elpitran+0.0 ! I am in water
18618        endif
18619        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18620        enddo
18621 ! here starts the side chain transfer
18622        do i=ilip_start,ilip_end
18623         if (itype(i,1).eq.ntyp1) cycle
18624         positi=(mod(c(3,i+nres),boxzsize))
18625         if (positi.le.0) positi=positi+boxzsize
18626 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18627 !c for each residue check if it is in lipid or lipid water border area
18628 !C       respos=mod(c(3,i+nres),boxzsize)
18629 !C       print *,positi,bordlipbot,buflipbot
18630        if ((positi.gt.bordlipbot) &
18631        .and.(positi.lt.bordliptop)) then
18632 !C the energy transfer exist
18633         if (positi.lt.buflipbot) then
18634          fracinbuf=1.0d0-   &
18635            ((positi-bordlipbot)/lipbufthick)
18636 !C lipbufthick is thickenes of lipid buffore
18637          sslip=sscalelip(fracinbuf)
18638          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18639          eliptran=eliptran+sslip*liptranene(itype(i,1))
18640          gliptranx(3,i)=gliptranx(3,i) &
18641       +ssgradlip*liptranene(itype(i,1))
18642          gliptranc(3,i-1)= gliptranc(3,i-1) &
18643       +ssgradlip*liptranene(itype(i,1))
18644 !C         print *,"doing sccale for lower part"
18645         elseif (positi.gt.bufliptop) then
18646          fracinbuf=1.0d0-  &
18647       ((bordliptop-positi)/lipbufthick)
18648          sslip=sscalelip(fracinbuf)
18649          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18650          eliptran=eliptran+sslip*liptranene(itype(i,1))
18651          gliptranx(3,i)=gliptranx(3,i)  &
18652        +ssgradlip*liptranene(itype(i,1))
18653          gliptranc(3,i-1)= gliptranc(3,i-1) &
18654       +ssgradlip*liptranene(itype(i,1))
18655 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18656         else
18657          eliptran=eliptran+liptranene(itype(i,1))
18658 !C         print *,"I am in true lipid"
18659         endif
18660         endif ! if in lipid or buffor
18661 !C       else
18662 !C       eliptran=elpitran+0.0 ! I am in water
18663         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18664        enddo
18665        return
18666        end  subroutine Eliptransfer
18667 !----------------------------------NANO FUNCTIONS
18668 !C-----------------------------------------------------------------------
18669 !C-----------------------------------------------------------
18670 !C This subroutine is to mimic the histone like structure but as well can be
18671 !C utilizet to nanostructures (infinit) small modification has to be used to
18672 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18673 !C gradient has to be modified at the ends
18674 !C The energy function is Kihara potential
18675 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18676 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18677 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18678 !C simple Kihara potential
18679       subroutine calctube(Etube)
18680       real(kind=8),dimension(3) :: vectube
18681       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18682        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18683        sc_aa_tube,sc_bb_tube
18684       integer :: i,j,iti
18685       Etube=0.0d0
18686       do i=itube_start,itube_end
18687         enetube(i)=0.0d0
18688         enetube(i+nres)=0.0d0
18689       enddo
18690 !C first we calculate the distance from tube center
18691 !C for UNRES
18692        do i=itube_start,itube_end
18693 !C lets ommit dummy atoms for now
18694        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18695 !C now calculate distance from center of tube and direction vectors
18696       xmin=boxxsize
18697       ymin=boxysize
18698 ! Find minimum distance in periodic box
18699         do j=-1,1
18700          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18701          vectube(1)=vectube(1)+boxxsize*j
18702          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18703          vectube(2)=vectube(2)+boxysize*j
18704          xminact=abs(vectube(1)-tubecenter(1))
18705          yminact=abs(vectube(2)-tubecenter(2))
18706            if (xmin.gt.xminact) then
18707             xmin=xminact
18708             xtemp=vectube(1)
18709            endif
18710            if (ymin.gt.yminact) then
18711              ymin=yminact
18712              ytemp=vectube(2)
18713             endif
18714          enddo
18715       vectube(1)=xtemp
18716       vectube(2)=ytemp
18717       vectube(1)=vectube(1)-tubecenter(1)
18718       vectube(2)=vectube(2)-tubecenter(2)
18719
18720 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18721 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18722
18723 !C as the tube is infinity we do not calculate the Z-vector use of Z
18724 !C as chosen axis
18725       vectube(3)=0.0d0
18726 !C now calculte the distance
18727        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18728 !C now normalize vector
18729       vectube(1)=vectube(1)/tub_r
18730       vectube(2)=vectube(2)/tub_r
18731 !C calculte rdiffrence between r and r0
18732       rdiff=tub_r-tubeR0
18733 !C and its 6 power
18734       rdiff6=rdiff**6.0d0
18735 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18736        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18737 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18738 !C       print *,rdiff,rdiff6,pep_aa_tube
18739 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18740 !C now we calculate gradient
18741        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18742             6.0d0*pep_bb_tube)/rdiff6/rdiff
18743 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18744 !C     &rdiff,fac
18745 !C now direction of gg_tube vector
18746         do j=1,3
18747         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18748         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18749         enddo
18750         enddo
18751 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18752 !C        print *,gg_tube(1,0),"TU"
18753
18754
18755        do i=itube_start,itube_end
18756 !C Lets not jump over memory as we use many times iti
18757          iti=itype(i,1)
18758 !C lets ommit dummy atoms for now
18759          if ((iti.eq.ntyp1)  &
18760 !C in UNRES uncomment the line below as GLY has no side-chain...
18761 !C      .or.(iti.eq.10)
18762         ) cycle
18763       xmin=boxxsize
18764       ymin=boxysize
18765         do j=-1,1
18766          vectube(1)=mod((c(1,i+nres)),boxxsize)
18767          vectube(1)=vectube(1)+boxxsize*j
18768          vectube(2)=mod((c(2,i+nres)),boxysize)
18769          vectube(2)=vectube(2)+boxysize*j
18770
18771          xminact=abs(vectube(1)-tubecenter(1))
18772          yminact=abs(vectube(2)-tubecenter(2))
18773            if (xmin.gt.xminact) then
18774             xmin=xminact
18775             xtemp=vectube(1)
18776            endif
18777            if (ymin.gt.yminact) then
18778              ymin=yminact
18779              ytemp=vectube(2)
18780             endif
18781          enddo
18782       vectube(1)=xtemp
18783       vectube(2)=ytemp
18784 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18785 !C     &     tubecenter(2)
18786       vectube(1)=vectube(1)-tubecenter(1)
18787       vectube(2)=vectube(2)-tubecenter(2)
18788
18789 !C as the tube is infinity we do not calculate the Z-vector use of Z
18790 !C as chosen axis
18791       vectube(3)=0.0d0
18792 !C now calculte the distance
18793        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18794 !C now normalize vector
18795       vectube(1)=vectube(1)/tub_r
18796       vectube(2)=vectube(2)/tub_r
18797
18798 !C calculte rdiffrence between r and r0
18799       rdiff=tub_r-tubeR0
18800 !C and its 6 power
18801       rdiff6=rdiff**6.0d0
18802 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18803        sc_aa_tube=sc_aa_tube_par(iti)
18804        sc_bb_tube=sc_bb_tube_par(iti)
18805        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18806        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18807              6.0d0*sc_bb_tube/rdiff6/rdiff
18808 !C now direction of gg_tube vector
18809          do j=1,3
18810           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18811           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18812          enddo
18813         enddo
18814         do i=itube_start,itube_end
18815           Etube=Etube+enetube(i)+enetube(i+nres)
18816         enddo
18817 !C        print *,"ETUBE", etube
18818         return
18819         end subroutine calctube
18820 !C TO DO 1) add to total energy
18821 !C       2) add to gradient summation
18822 !C       3) add reading parameters (AND of course oppening of PARAM file)
18823 !C       4) add reading the center of tube
18824 !C       5) add COMMONs
18825 !C       6) add to zerograd
18826 !C       7) allocate matrices
18827
18828
18829 !C-----------------------------------------------------------------------
18830 !C-----------------------------------------------------------
18831 !C This subroutine is to mimic the histone like structure but as well can be
18832 !C utilizet to nanostructures (infinit) small modification has to be used to
18833 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18834 !C gradient has to be modified at the ends
18835 !C The energy function is Kihara potential
18836 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18837 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18838 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18839 !C simple Kihara potential
18840       subroutine calctube2(Etube)
18841             real(kind=8),dimension(3) :: vectube
18842       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18843        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18844        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18845       integer:: i,j,iti
18846       Etube=0.0d0
18847       do i=itube_start,itube_end
18848         enetube(i)=0.0d0
18849         enetube(i+nres)=0.0d0
18850       enddo
18851 !C first we calculate the distance from tube center
18852 !C first sugare-phosphate group for NARES this would be peptide group
18853 !C for UNRES
18854        do i=itube_start,itube_end
18855 !C lets ommit dummy atoms for now
18856
18857        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18858 !C now calculate distance from center of tube and direction vectors
18859 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18860 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18861 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18862 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18863       xmin=boxxsize
18864       ymin=boxysize
18865         do j=-1,1
18866          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18867          vectube(1)=vectube(1)+boxxsize*j
18868          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18869          vectube(2)=vectube(2)+boxysize*j
18870
18871          xminact=abs(vectube(1)-tubecenter(1))
18872          yminact=abs(vectube(2)-tubecenter(2))
18873            if (xmin.gt.xminact) then
18874             xmin=xminact
18875             xtemp=vectube(1)
18876            endif
18877            if (ymin.gt.yminact) then
18878              ymin=yminact
18879              ytemp=vectube(2)
18880             endif
18881          enddo
18882       vectube(1)=xtemp
18883       vectube(2)=ytemp
18884       vectube(1)=vectube(1)-tubecenter(1)
18885       vectube(2)=vectube(2)-tubecenter(2)
18886
18887 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18888 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18889
18890 !C as the tube is infinity we do not calculate the Z-vector use of Z
18891 !C as chosen axis
18892       vectube(3)=0.0d0
18893 !C now calculte the distance
18894        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18895 !C now normalize vector
18896       vectube(1)=vectube(1)/tub_r
18897       vectube(2)=vectube(2)/tub_r
18898 !C calculte rdiffrence between r and r0
18899       rdiff=tub_r-tubeR0
18900 !C and its 6 power
18901       rdiff6=rdiff**6.0d0
18902 !C THIS FRAGMENT MAKES TUBE FINITE
18903         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18904         if (positi.le.0) positi=positi+boxzsize
18905 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18906 !c for each residue check if it is in lipid or lipid water border area
18907 !C       respos=mod(c(3,i+nres),boxzsize)
18908 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18909        if ((positi.gt.bordtubebot)  &
18910         .and.(positi.lt.bordtubetop)) then
18911 !C the energy transfer exist
18912         if (positi.lt.buftubebot) then
18913          fracinbuf=1.0d0-  &
18914            ((positi-bordtubebot)/tubebufthick)
18915 !C lipbufthick is thickenes of lipid buffore
18916          sstube=sscalelip(fracinbuf)
18917          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18918 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18919          enetube(i)=enetube(i)+sstube*tubetranenepep
18920 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18921 !C     &+ssgradtube*tubetranene(itype(i,1))
18922 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18923 !C     &+ssgradtube*tubetranene(itype(i,1))
18924 !C         print *,"doing sccale for lower part"
18925         elseif (positi.gt.buftubetop) then
18926          fracinbuf=1.0d0-  &
18927         ((bordtubetop-positi)/tubebufthick)
18928          sstube=sscalelip(fracinbuf)
18929          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18930          enetube(i)=enetube(i)+sstube*tubetranenepep
18931 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18932 !C     &+ssgradtube*tubetranene(itype(i,1))
18933 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18934 !C     &+ssgradtube*tubetranene(itype(i,1))
18935 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18936         else
18937          sstube=1.0d0
18938          ssgradtube=0.0d0
18939          enetube(i)=enetube(i)+sstube*tubetranenepep
18940 !C         print *,"I am in true lipid"
18941         endif
18942         else
18943 !C          sstube=0.0d0
18944 !C          ssgradtube=0.0d0
18945         cycle
18946         endif ! if in lipid or buffor
18947
18948 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18949        enetube(i)=enetube(i)+sstube* &
18950         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18951 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18952 !C       print *,rdiff,rdiff6,pep_aa_tube
18953 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18954 !C now we calculate gradient
18955        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18956              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18957 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18958 !C     &rdiff,fac
18959
18960 !C now direction of gg_tube vector
18961        do j=1,3
18962         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18963         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18964         enddo
18965          gg_tube(3,i)=gg_tube(3,i)  &
18966        +ssgradtube*enetube(i)/sstube/2.0d0
18967          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18968        +ssgradtube*enetube(i)/sstube/2.0d0
18969
18970         enddo
18971 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18972 !C        print *,gg_tube(1,0),"TU"
18973         do i=itube_start,itube_end
18974 !C Lets not jump over memory as we use many times iti
18975          iti=itype(i,1)
18976 !C lets ommit dummy atoms for now
18977          if ((iti.eq.ntyp1) &
18978 !!C in UNRES uncomment the line below as GLY has no side-chain...
18979            .or.(iti.eq.10) &
18980           ) cycle
18981           vectube(1)=c(1,i+nres)
18982           vectube(1)=mod(vectube(1),boxxsize)
18983           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18984           vectube(2)=c(2,i+nres)
18985           vectube(2)=mod(vectube(2),boxysize)
18986           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18987
18988       vectube(1)=vectube(1)-tubecenter(1)
18989       vectube(2)=vectube(2)-tubecenter(2)
18990 !C THIS FRAGMENT MAKES TUBE FINITE
18991         positi=(mod(c(3,i+nres),boxzsize))
18992         if (positi.le.0) positi=positi+boxzsize
18993 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18994 !c for each residue check if it is in lipid or lipid water border area
18995 !C       respos=mod(c(3,i+nres),boxzsize)
18996 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18997
18998        if ((positi.gt.bordtubebot)  &
18999         .and.(positi.lt.bordtubetop)) then
19000 !C the energy transfer exist
19001         if (positi.lt.buftubebot) then
19002          fracinbuf=1.0d0- &
19003             ((positi-bordtubebot)/tubebufthick)
19004 !C lipbufthick is thickenes of lipid buffore
19005          sstube=sscalelip(fracinbuf)
19006          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19007 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19008          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19009 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19010 !C     &+ssgradtube*tubetranene(itype(i,1))
19011 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19012 !C     &+ssgradtube*tubetranene(itype(i,1))
19013 !C         print *,"doing sccale for lower part"
19014         elseif (positi.gt.buftubetop) then
19015          fracinbuf=1.0d0- &
19016         ((bordtubetop-positi)/tubebufthick)
19017
19018          sstube=sscalelip(fracinbuf)
19019          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19020          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19021 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19022 !C     &+ssgradtube*tubetranene(itype(i,1))
19023 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19024 !C     &+ssgradtube*tubetranene(itype(i,1))
19025 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19026         else
19027          sstube=1.0d0
19028          ssgradtube=0.0d0
19029          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19030 !C         print *,"I am in true lipid"
19031         endif
19032         else
19033 !C          sstube=0.0d0
19034 !C          ssgradtube=0.0d0
19035         cycle
19036         endif ! if in lipid or buffor
19037 !CEND OF FINITE FRAGMENT
19038 !C as the tube is infinity we do not calculate the Z-vector use of Z
19039 !C as chosen axis
19040       vectube(3)=0.0d0
19041 !C now calculte the distance
19042        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19043 !C now normalize vector
19044       vectube(1)=vectube(1)/tub_r
19045       vectube(2)=vectube(2)/tub_r
19046 !C calculte rdiffrence between r and r0
19047       rdiff=tub_r-tubeR0
19048 !C and its 6 power
19049       rdiff6=rdiff**6.0d0
19050 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19051        sc_aa_tube=sc_aa_tube_par(iti)
19052        sc_bb_tube=sc_bb_tube_par(iti)
19053        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19054                        *sstube+enetube(i+nres)
19055 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19056 !C now we calculate gradient
19057        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19058             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19059 !C now direction of gg_tube vector
19060          do j=1,3
19061           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19062           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19063          enddo
19064          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19065        +ssgradtube*enetube(i+nres)/sstube
19066          gg_tube(3,i-1)= gg_tube(3,i-1) &
19067        +ssgradtube*enetube(i+nres)/sstube
19068
19069         enddo
19070         do i=itube_start,itube_end
19071           Etube=Etube+enetube(i)+enetube(i+nres)
19072         enddo
19073 !C        print *,"ETUBE", etube
19074         return
19075         end subroutine calctube2
19076 !=====================================================================================================================================
19077       subroutine calcnano(Etube)
19078       real(kind=8),dimension(3) :: vectube
19079
19080       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19081        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19082        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19083        integer:: i,j,iti,r
19084
19085       Etube=0.0d0
19086 !      print *,itube_start,itube_end,"poczatek"
19087       do i=itube_start,itube_end
19088         enetube(i)=0.0d0
19089         enetube(i+nres)=0.0d0
19090       enddo
19091 !C first we calculate the distance from tube center
19092 !C first sugare-phosphate group for NARES this would be peptide group
19093 !C for UNRES
19094        do i=itube_start,itube_end
19095 !C lets ommit dummy atoms for now
19096        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19097 !C now calculate distance from center of tube and direction vectors
19098       xmin=boxxsize
19099       ymin=boxysize
19100       zmin=boxzsize
19101
19102         do j=-1,1
19103          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19104          vectube(1)=vectube(1)+boxxsize*j
19105          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19106          vectube(2)=vectube(2)+boxysize*j
19107          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19108          vectube(3)=vectube(3)+boxzsize*j
19109
19110
19111          xminact=dabs(vectube(1)-tubecenter(1))
19112          yminact=dabs(vectube(2)-tubecenter(2))
19113          zminact=dabs(vectube(3)-tubecenter(3))
19114
19115            if (xmin.gt.xminact) then
19116             xmin=xminact
19117             xtemp=vectube(1)
19118            endif
19119            if (ymin.gt.yminact) then
19120              ymin=yminact
19121              ytemp=vectube(2)
19122             endif
19123            if (zmin.gt.zminact) then
19124              zmin=zminact
19125              ztemp=vectube(3)
19126             endif
19127          enddo
19128       vectube(1)=xtemp
19129       vectube(2)=ytemp
19130       vectube(3)=ztemp
19131
19132       vectube(1)=vectube(1)-tubecenter(1)
19133       vectube(2)=vectube(2)-tubecenter(2)
19134       vectube(3)=vectube(3)-tubecenter(3)
19135
19136 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19137 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19138 !C as the tube is infinity we do not calculate the Z-vector use of Z
19139 !C as chosen axis
19140 !C      vectube(3)=0.0d0
19141 !C now calculte the distance
19142        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19143 !C now normalize vector
19144       vectube(1)=vectube(1)/tub_r
19145       vectube(2)=vectube(2)/tub_r
19146       vectube(3)=vectube(3)/tub_r
19147 !C calculte rdiffrence between r and r0
19148       rdiff=tub_r-tubeR0
19149 !C and its 6 power
19150       rdiff6=rdiff**6.0d0
19151 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19152        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19153 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19154 !C       print *,rdiff,rdiff6,pep_aa_tube
19155 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19156 !C now we calculate gradient
19157        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19158             6.0d0*pep_bb_tube)/rdiff6/rdiff
19159 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19160 !C     &rdiff,fac
19161          if (acavtubpep.eq.0.0d0) then
19162 !C go to 667
19163          enecavtube(i)=0.0
19164          faccav=0.0
19165          else
19166          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19167          enecavtube(i)=  &
19168         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19169         /denominator
19170          enecavtube(i)=0.0
19171          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19172         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19173         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19174         /denominator**2.0d0
19175 !C         faccav=0.0
19176 !C         fac=fac+faccav
19177 !C 667     continue
19178          endif
19179           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19180         do j=1,3
19181         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19182         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19183         enddo
19184         enddo
19185
19186        do i=itube_start,itube_end
19187         enecavtube(i)=0.0d0
19188 !C Lets not jump over memory as we use many times iti
19189          iti=itype(i,1)
19190 !C lets ommit dummy atoms for now
19191          if ((iti.eq.ntyp1) &
19192 !C in UNRES uncomment the line below as GLY has no side-chain...
19193 !C      .or.(iti.eq.10)
19194          ) cycle
19195       xmin=boxxsize
19196       ymin=boxysize
19197       zmin=boxzsize
19198         do j=-1,1
19199          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19200          vectube(1)=vectube(1)+boxxsize*j
19201          vectube(2)=dmod((c(2,i+nres)),boxysize)
19202          vectube(2)=vectube(2)+boxysize*j
19203          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19204          vectube(3)=vectube(3)+boxzsize*j
19205
19206
19207          xminact=dabs(vectube(1)-tubecenter(1))
19208          yminact=dabs(vectube(2)-tubecenter(2))
19209          zminact=dabs(vectube(3)-tubecenter(3))
19210
19211            if (xmin.gt.xminact) then
19212             xmin=xminact
19213             xtemp=vectube(1)
19214            endif
19215            if (ymin.gt.yminact) then
19216              ymin=yminact
19217              ytemp=vectube(2)
19218             endif
19219            if (zmin.gt.zminact) then
19220              zmin=zminact
19221              ztemp=vectube(3)
19222             endif
19223          enddo
19224       vectube(1)=xtemp
19225       vectube(2)=ytemp
19226       vectube(3)=ztemp
19227
19228 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19229 !C     &     tubecenter(2)
19230       vectube(1)=vectube(1)-tubecenter(1)
19231       vectube(2)=vectube(2)-tubecenter(2)
19232       vectube(3)=vectube(3)-tubecenter(3)
19233 !C now calculte the distance
19234        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19235 !C now normalize vector
19236       vectube(1)=vectube(1)/tub_r
19237       vectube(2)=vectube(2)/tub_r
19238       vectube(3)=vectube(3)/tub_r
19239
19240 !C calculte rdiffrence between r and r0
19241       rdiff=tub_r-tubeR0
19242 !C and its 6 power
19243       rdiff6=rdiff**6.0d0
19244        sc_aa_tube=sc_aa_tube_par(iti)
19245        sc_bb_tube=sc_bb_tube_par(iti)
19246        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19247 !C       enetube(i+nres)=0.0d0
19248 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19249 !C now we calculate gradient
19250        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19251             6.0d0*sc_bb_tube/rdiff6/rdiff
19252 !C       fac=0.0
19253 !C now direction of gg_tube vector
19254 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19255          if (acavtub(iti).eq.0.0d0) then
19256 !C go to 667
19257          enecavtube(i+nres)=0.0d0
19258          faccav=0.0d0
19259          else
19260          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19261          enecavtube(i+nres)=   &
19262         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19263         /denominator
19264 !C         enecavtube(i)=0.0
19265          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19266         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19267         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19268         /denominator**2.0d0
19269 !C         faccav=0.0
19270          fac=fac+faccav
19271 !C 667     continue
19272          endif
19273 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19274 !C     &   enecavtube(i),faccav
19275 !C         print *,"licz=",
19276 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19277 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19278          do j=1,3
19279           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19280           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19281          enddo
19282           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19283         enddo
19284
19285
19286
19287         do i=itube_start,itube_end
19288           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19289          +enecavtube(i+nres)
19290         enddo
19291 !        do i=1,20
19292 !         print *,"begin", i,"a"
19293 !         do r=1,10000
19294 !          rdiff=r/100.0d0
19295 !          rdiff6=rdiff**6.0d0
19296 !          sc_aa_tube=sc_aa_tube_par(i)
19297 !          sc_bb_tube=sc_bb_tube_par(i)
19298 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19299 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19300 !          enecavtube(i)=   &
19301 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19302 !         /denominator
19303
19304 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19305 !         enddo
19306 !         print *,"end",i,"a"
19307 !        enddo
19308 !C        print *,"ETUBE", etube
19309         return
19310         end subroutine calcnano
19311
19312 !===============================================
19313 !--------------------------------------------------------------------------------
19314 !C first for shielding is setting of function of side-chains
19315
19316        subroutine set_shield_fac2
19317        real(kind=8) :: div77_81=0.974996043d0, &
19318         div4_81=0.2222222222d0
19319        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19320          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19321          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19322          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19323 !C the vector between center of side_chain and peptide group
19324        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19325          pept_group,costhet_grad,cosphi_grad_long, &
19326          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19327          sh_frac_dist_grad,pep_side
19328         integer i,j,k
19329 !C      write(2,*) "ivec",ivec_start,ivec_end
19330       do i=1,nres
19331         fac_shield(i)=0.0d0
19332         do j=1,3
19333         grad_shield(j,i)=0.0d0
19334         enddo
19335       enddo
19336       do i=ivec_start,ivec_end
19337 !C      do i=1,nres-1
19338 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19339       ishield_list(i)=0
19340       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19341 !Cif there two consequtive dummy atoms there is no peptide group between them
19342 !C the line below has to be changed for FGPROC>1
19343       VolumeTotal=0.0
19344       do k=1,nres
19345        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19346        dist_pep_side=0.0
19347        dist_side_calf=0.0
19348        do j=1,3
19349 !C first lets set vector conecting the ithe side-chain with kth side-chain
19350       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19351 !C      pep_side(j)=2.0d0
19352 !C and vector conecting the side-chain with its proper calfa
19353       side_calf(j)=c(j,k+nres)-c(j,k)
19354 !C      side_calf(j)=2.0d0
19355       pept_group(j)=c(j,i)-c(j,i+1)
19356 !C lets have their lenght
19357       dist_pep_side=pep_side(j)**2+dist_pep_side
19358       dist_side_calf=dist_side_calf+side_calf(j)**2
19359       dist_pept_group=dist_pept_group+pept_group(j)**2
19360       enddo
19361        dist_pep_side=sqrt(dist_pep_side)
19362        dist_pept_group=sqrt(dist_pept_group)
19363        dist_side_calf=sqrt(dist_side_calf)
19364       do j=1,3
19365         pep_side_norm(j)=pep_side(j)/dist_pep_side
19366         side_calf_norm(j)=dist_side_calf
19367       enddo
19368 !C now sscale fraction
19369        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19370 !C       print *,buff_shield,"buff"
19371 !C now sscale
19372         if (sh_frac_dist.le.0.0) cycle
19373 !C        print *,ishield_list(i),i
19374 !C If we reach here it means that this side chain reaches the shielding sphere
19375 !C Lets add him to the list for gradient
19376         ishield_list(i)=ishield_list(i)+1
19377 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19378 !C this list is essential otherwise problem would be O3
19379         shield_list(ishield_list(i),i)=k
19380 !C Lets have the sscale value
19381         if (sh_frac_dist.gt.1.0) then
19382          scale_fac_dist=1.0d0
19383          do j=1,3
19384          sh_frac_dist_grad(j)=0.0d0
19385          enddo
19386         else
19387          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19388                         *(2.0d0*sh_frac_dist-3.0d0)
19389          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19390                        /dist_pep_side/buff_shield*0.5d0
19391          do j=1,3
19392          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19393 !C         sh_frac_dist_grad(j)=0.0d0
19394 !C         scale_fac_dist=1.0d0
19395 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19396 !C     &                    sh_frac_dist_grad(j)
19397          enddo
19398         endif
19399 !C this is what is now we have the distance scaling now volume...
19400       short=short_r_sidechain(itype(k,1))
19401       long=long_r_sidechain(itype(k,1))
19402       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19403       sinthet=short/dist_pep_side*costhet
19404 !C now costhet_grad
19405 !C       costhet=0.6d0
19406 !C       sinthet=0.8
19407        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19408 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19409 !C     &             -short/dist_pep_side**2/costhet)
19410 !C       costhet_fac=0.0d0
19411        do j=1,3
19412          costhet_grad(j)=costhet_fac*pep_side(j)
19413        enddo
19414 !C remember for the final gradient multiply costhet_grad(j)
19415 !C for side_chain by factor -2 !
19416 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19417 !C pep_side0pept_group is vector multiplication
19418       pep_side0pept_group=0.0d0
19419       do j=1,3
19420       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19421       enddo
19422       cosalfa=(pep_side0pept_group/ &
19423       (dist_pep_side*dist_side_calf))
19424       fac_alfa_sin=1.0d0-cosalfa**2
19425       fac_alfa_sin=dsqrt(fac_alfa_sin)
19426       rkprim=fac_alfa_sin*(long-short)+short
19427 !C      rkprim=short
19428
19429 !C now costhet_grad
19430        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19431 !C       cosphi=0.6
19432        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19433        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19434            dist_pep_side**2)
19435 !C       sinphi=0.8
19436        do j=1,3
19437          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19438       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19439       *(long-short)/fac_alfa_sin*cosalfa/ &
19440       ((dist_pep_side*dist_side_calf))* &
19441       ((side_calf(j))-cosalfa* &
19442       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19443 !C       cosphi_grad_long(j)=0.0d0
19444         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19445       *(long-short)/fac_alfa_sin*cosalfa &
19446       /((dist_pep_side*dist_side_calf))* &
19447       (pep_side(j)- &
19448       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19449 !C       cosphi_grad_loc(j)=0.0d0
19450        enddo
19451 !C      print *,sinphi,sinthet
19452       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19453      &                    /VSolvSphere_div
19454 !C     &                    *wshield
19455 !C now the gradient...
19456       do j=1,3
19457       grad_shield(j,i)=grad_shield(j,i) &
19458 !C gradient po skalowaniu
19459                      +(sh_frac_dist_grad(j)*VofOverlap &
19460 !C  gradient po costhet
19461             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19462         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19463             sinphi/sinthet*costhet*costhet_grad(j) &
19464            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19465         )*wshield
19466 !C grad_shield_side is Cbeta sidechain gradient
19467       grad_shield_side(j,ishield_list(i),i)=&
19468              (sh_frac_dist_grad(j)*-2.0d0&
19469              *VofOverlap&
19470             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19471        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19472             sinphi/sinthet*costhet*costhet_grad(j)&
19473            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19474             )*wshield
19475
19476        grad_shield_loc(j,ishield_list(i),i)=   &
19477             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19478       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19479             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19480              ))&
19481              *wshield
19482       enddo
19483       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19484       enddo
19485       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19486
19487 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19488       enddo
19489       return
19490       end subroutine set_shield_fac2
19491 !----------------------------------------------------------------------------
19492 ! SOUBROUTINE FOR AFM
19493        subroutine AFMvel(Eafmforce)
19494        use MD_data, only:totTafm
19495       real(kind=8),dimension(3) :: diffafm
19496       real(kind=8) :: afmdist,Eafmforce
19497        integer :: i
19498 !C Only for check grad COMMENT if not used for checkgrad
19499 !C      totT=3.0d0
19500 !C--------------------------------------------------------
19501 !C      print *,"wchodze"
19502       afmdist=0.0d0
19503       Eafmforce=0.0d0
19504       do i=1,3
19505       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19506       afmdist=afmdist+diffafm(i)**2
19507       enddo
19508       afmdist=dsqrt(afmdist)
19509 !      totTafm=3.0
19510       Eafmforce=0.5d0*forceAFMconst &
19511       *(distafminit+totTafm*velAFMconst-afmdist)**2
19512 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19513       do i=1,3
19514       gradafm(i,afmend-1)=-forceAFMconst* &
19515        (distafminit+totTafm*velAFMconst-afmdist) &
19516        *diffafm(i)/afmdist
19517       gradafm(i,afmbeg-1)=forceAFMconst* &
19518       (distafminit+totTafm*velAFMconst-afmdist) &
19519       *diffafm(i)/afmdist
19520       enddo
19521 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19522       return
19523       end subroutine AFMvel
19524 !---------------------------------------------------------
19525        subroutine AFMforce(Eafmforce)
19526
19527       real(kind=8),dimension(3) :: diffafm
19528 !      real(kind=8) ::afmdist
19529       real(kind=8) :: afmdist,Eafmforce
19530       integer :: i
19531       afmdist=0.0d0
19532       Eafmforce=0.0d0
19533       do i=1,3
19534       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19535       afmdist=afmdist+diffafm(i)**2
19536       enddo
19537       afmdist=dsqrt(afmdist)
19538 !      print *,afmdist,distafminit
19539       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19540       do i=1,3
19541       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19542       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19543       enddo
19544 !C      print *,'AFM',Eafmforce
19545       return
19546       end subroutine AFMforce
19547
19548 !-----------------------------------------------------------------------------
19549 #ifdef WHAM
19550       subroutine read_ssHist
19551 !      implicit none
19552 !      Includes
19553 !      include 'DIMENSIONS'
19554 !      include "DIMENSIONS.FREE"
19555 !      include 'COMMON.FREE'
19556 !     Local variables
19557       integer :: i,j
19558       character(len=80) :: controlcard
19559
19560       do i=1,dyn_nssHist
19561         call card_concat(controlcard,.true.)
19562         read(controlcard,*) &
19563              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19564       enddo
19565
19566       return
19567       end subroutine read_ssHist
19568 #endif
19569 !-----------------------------------------------------------------------------
19570       integer function indmat(i,j)
19571 !el
19572 ! get the position of the jth ijth fragment of the chain coordinate system
19573 ! in the fromto array.
19574         integer :: i,j
19575
19576         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19577       return
19578       end function indmat
19579 !-----------------------------------------------------------------------------
19580       real(kind=8) function sigm(x)
19581 !el
19582        real(kind=8) :: x
19583         sigm=0.25d0*x
19584       return
19585       end function sigm
19586 !-----------------------------------------------------------------------------
19587 !-----------------------------------------------------------------------------
19588       subroutine alloc_ener_arrays
19589 !EL Allocation of arrays used by module energy
19590       use MD_data, only: mset
19591 !el local variables
19592       integer :: i,j
19593
19594       if(nres.lt.100) then
19595         maxconts=nres
19596       elseif(nres.lt.200) then
19597         maxconts=0.8*nres      ! Max. number of contacts per residue
19598       else
19599         maxconts=0.6*nres ! (maxconts=maxres/4)
19600       endif
19601       maxcont=12*nres      ! Max. number of SC contacts
19602       maxvar=6*nres      ! Max. number of variables
19603 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19604       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19605 !----------------------
19606 ! arrays in subroutine init_int_table
19607 !el#ifdef MPI
19608 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19609 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19610 !el#endif
19611       allocate(nint_gr(nres))
19612       allocate(nscp_gr(nres))
19613       allocate(ielstart(nres))
19614       allocate(ielend(nres))
19615 !(maxres)
19616       allocate(istart(nres,maxint_gr))
19617       allocate(iend(nres,maxint_gr))
19618 !(maxres,maxint_gr)
19619       allocate(iscpstart(nres,maxint_gr))
19620       allocate(iscpend(nres,maxint_gr))
19621 !(maxres,maxint_gr)
19622       allocate(ielstart_vdw(nres))
19623       allocate(ielend_vdw(nres))
19624 !(maxres)
19625       allocate(nint_gr_nucl(nres))
19626       allocate(nscp_gr_nucl(nres))
19627       allocate(ielstart_nucl(nres))
19628       allocate(ielend_nucl(nres))
19629 !(maxres)
19630       allocate(istart_nucl(nres,maxint_gr))
19631       allocate(iend_nucl(nres,maxint_gr))
19632 !(maxres,maxint_gr)
19633       allocate(iscpstart_nucl(nres,maxint_gr))
19634       allocate(iscpend_nucl(nres,maxint_gr))
19635 !(maxres,maxint_gr)
19636       allocate(ielstart_vdw_nucl(nres))
19637       allocate(ielend_vdw_nucl(nres))
19638
19639       allocate(lentyp(0:nfgtasks-1))
19640 !(0:maxprocs-1)
19641 !----------------------
19642 ! commom.contacts
19643 !      common /contacts/
19644       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19645       allocate(icont(2,maxcont))
19646 !(2,maxcont)
19647 !      common /contacts1/
19648       allocate(num_cont(0:nres+4))
19649 !(maxres)
19650       allocate(jcont(maxconts,nres))
19651 !(maxconts,maxres)
19652       allocate(facont(maxconts,nres))
19653 !(maxconts,maxres)
19654       allocate(gacont(3,maxconts,nres))
19655 !(3,maxconts,maxres)
19656 !      common /contacts_hb/
19657       allocate(gacontp_hb1(3,maxconts,nres))
19658       allocate(gacontp_hb2(3,maxconts,nres))
19659       allocate(gacontp_hb3(3,maxconts,nres))
19660       allocate(gacontm_hb1(3,maxconts,nres))
19661       allocate(gacontm_hb2(3,maxconts,nres))
19662       allocate(gacontm_hb3(3,maxconts,nres))
19663       allocate(gacont_hbr(3,maxconts,nres))
19664       allocate(grij_hb_cont(3,maxconts,nres))
19665 !(3,maxconts,maxres)
19666       allocate(facont_hb(maxconts,nres))
19667
19668       allocate(ees0p(maxconts,nres))
19669       allocate(ees0m(maxconts,nres))
19670       allocate(d_cont(maxconts,nres))
19671       allocate(ees0plist(maxconts,nres))
19672
19673 !(maxconts,maxres)
19674       allocate(num_cont_hb(nres))
19675 !(maxres)
19676       allocate(jcont_hb(maxconts,nres))
19677 !(maxconts,maxres)
19678 !      common /rotat/
19679       allocate(Ug(2,2,nres))
19680       allocate(Ugder(2,2,nres))
19681       allocate(Ug2(2,2,nres))
19682       allocate(Ug2der(2,2,nres))
19683 !(2,2,maxres)
19684       allocate(obrot(2,nres))
19685       allocate(obrot2(2,nres))
19686       allocate(obrot_der(2,nres))
19687       allocate(obrot2_der(2,nres))
19688 !(2,maxres)
19689 !      common /precomp1/
19690       allocate(mu(2,nres))
19691       allocate(muder(2,nres))
19692       allocate(Ub2(2,nres))
19693       Ub2(1,:)=0.0d0
19694       Ub2(2,:)=0.0d0
19695       allocate(Ub2der(2,nres))
19696       allocate(Ctobr(2,nres))
19697       allocate(Ctobrder(2,nres))
19698       allocate(Dtobr2(2,nres))
19699       allocate(Dtobr2der(2,nres))
19700 !(2,maxres)
19701       allocate(EUg(2,2,nres))
19702       allocate(EUgder(2,2,nres))
19703       allocate(CUg(2,2,nres))
19704       allocate(CUgder(2,2,nres))
19705       allocate(DUg(2,2,nres))
19706       allocate(Dugder(2,2,nres))
19707       allocate(DtUg2(2,2,nres))
19708       allocate(DtUg2der(2,2,nres))
19709 !(2,2,maxres)
19710 !      common /precomp2/
19711       allocate(Ug2Db1t(2,nres))
19712       allocate(Ug2Db1tder(2,nres))
19713       allocate(CUgb2(2,nres))
19714       allocate(CUgb2der(2,nres))
19715 !(2,maxres)
19716       allocate(EUgC(2,2,nres))
19717       allocate(EUgCder(2,2,nres))
19718       allocate(EUgD(2,2,nres))
19719       allocate(EUgDder(2,2,nres))
19720       allocate(DtUg2EUg(2,2,nres))
19721       allocate(Ug2DtEUg(2,2,nres))
19722 !(2,2,maxres)
19723       allocate(Ug2DtEUgder(2,2,2,nres))
19724       allocate(DtUg2EUgder(2,2,2,nres))
19725 !(2,2,2,maxres)
19726 !      common /rotat_old/
19727       allocate(costab(nres))
19728       allocate(sintab(nres))
19729       allocate(costab2(nres))
19730       allocate(sintab2(nres))
19731 !(maxres)
19732 !      common /dipmat/
19733       allocate(a_chuj(2,2,maxconts,nres))
19734 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19735       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19736 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19737 !      common /contdistrib/
19738       allocate(ncont_sent(nres))
19739       allocate(ncont_recv(nres))
19740
19741       allocate(iat_sent(nres))
19742 !(maxres)
19743       allocate(iint_sent(4,nres,nres))
19744       allocate(iint_sent_local(4,nres,nres))
19745 !(4,maxres,maxres)
19746       allocate(iturn3_sent(4,0:nres+4))
19747       allocate(iturn4_sent(4,0:nres+4))
19748       allocate(iturn3_sent_local(4,nres))
19749       allocate(iturn4_sent_local(4,nres))
19750 !(4,maxres)
19751       allocate(itask_cont_from(0:nfgtasks-1))
19752       allocate(itask_cont_to(0:nfgtasks-1))
19753 !(0:max_fg_procs-1)
19754
19755
19756
19757 !----------------------
19758 ! commom.deriv;
19759 !      common /derivat/
19760       allocate(dcdv(6,maxdim))
19761       allocate(dxdv(6,maxdim))
19762 !(6,maxdim)
19763       allocate(dxds(6,nres))
19764 !(6,maxres)
19765       allocate(gradx(3,-1:nres,0:2))
19766       allocate(gradc(3,-1:nres,0:2))
19767 !(3,maxres,2)
19768       allocate(gvdwx(3,-1:nres))
19769       allocate(gvdwc(3,-1:nres))
19770       allocate(gelc(3,-1:nres))
19771       allocate(gelc_long(3,-1:nres))
19772       allocate(gvdwpp(3,-1:nres))
19773       allocate(gvdwc_scpp(3,-1:nres))
19774       allocate(gradx_scp(3,-1:nres))
19775       allocate(gvdwc_scp(3,-1:nres))
19776       allocate(ghpbx(3,-1:nres))
19777       allocate(ghpbc(3,-1:nres))
19778       allocate(gradcorr(3,-1:nres))
19779       allocate(gradcorr_long(3,-1:nres))
19780       allocate(gradcorr5_long(3,-1:nres))
19781       allocate(gradcorr6_long(3,-1:nres))
19782       allocate(gcorr6_turn_long(3,-1:nres))
19783       allocate(gradxorr(3,-1:nres))
19784       allocate(gradcorr5(3,-1:nres))
19785       allocate(gradcorr6(3,-1:nres))
19786       allocate(gliptran(3,-1:nres))
19787       allocate(gliptranc(3,-1:nres))
19788       allocate(gliptranx(3,-1:nres))
19789       allocate(gshieldx(3,-1:nres))
19790       allocate(gshieldc(3,-1:nres))
19791       allocate(gshieldc_loc(3,-1:nres))
19792       allocate(gshieldx_ec(3,-1:nres))
19793       allocate(gshieldc_ec(3,-1:nres))
19794       allocate(gshieldc_loc_ec(3,-1:nres))
19795       allocate(gshieldx_t3(3,-1:nres))
19796       allocate(gshieldc_t3(3,-1:nres))
19797       allocate(gshieldc_loc_t3(3,-1:nres))
19798       allocate(gshieldx_t4(3,-1:nres))
19799       allocate(gshieldc_t4(3,-1:nres))
19800       allocate(gshieldc_loc_t4(3,-1:nres))
19801       allocate(gshieldx_ll(3,-1:nres))
19802       allocate(gshieldc_ll(3,-1:nres))
19803       allocate(gshieldc_loc_ll(3,-1:nres))
19804       allocate(grad_shield(3,-1:nres))
19805       allocate(gg_tube_sc(3,-1:nres))
19806       allocate(gg_tube(3,-1:nres))
19807       allocate(gradafm(3,-1:nres))
19808       allocate(gradb_nucl(3,-1:nres))
19809       allocate(gradbx_nucl(3,-1:nres))
19810       allocate(gvdwpsb1(3,-1:nres))
19811       allocate(gelpp(3,-1:nres))
19812       allocate(gvdwpsb(3,-1:nres))
19813       allocate(gelsbc(3,-1:nres))
19814       allocate(gelsbx(3,-1:nres))
19815       allocate(gvdwsbx(3,-1:nres))
19816       allocate(gvdwsbc(3,-1:nres))
19817       allocate(gsbloc(3,-1:nres))
19818       allocate(gsblocx(3,-1:nres))
19819       allocate(gradcorr_nucl(3,-1:nres))
19820       allocate(gradxorr_nucl(3,-1:nres))
19821       allocate(gradcorr3_nucl(3,-1:nres))
19822       allocate(gradxorr3_nucl(3,-1:nres))
19823       allocate(gvdwpp_nucl(3,-1:nres))
19824       allocate(gradpepcat(3,-1:nres))
19825       allocate(gradpepcatx(3,-1:nres))
19826       allocate(gradcatcat(3,-1:nres))
19827 !(3,maxres)
19828       allocate(grad_shield_side(3,50,nres))
19829       allocate(grad_shield_loc(3,50,nres))
19830 ! grad for shielding surroing
19831       allocate(gloc(0:maxvar,0:2))
19832       allocate(gloc_x(0:maxvar,2))
19833 !(maxvar,2)
19834       allocate(gel_loc(3,-1:nres))
19835       allocate(gel_loc_long(3,-1:nres))
19836       allocate(gcorr3_turn(3,-1:nres))
19837       allocate(gcorr4_turn(3,-1:nres))
19838       allocate(gcorr6_turn(3,-1:nres))
19839       allocate(gradb(3,-1:nres))
19840       allocate(gradbx(3,-1:nres))
19841 !(3,maxres)
19842       allocate(gel_loc_loc(maxvar))
19843       allocate(gel_loc_turn3(maxvar))
19844       allocate(gel_loc_turn4(maxvar))
19845       allocate(gel_loc_turn6(maxvar))
19846       allocate(gcorr_loc(maxvar))
19847       allocate(g_corr5_loc(maxvar))
19848       allocate(g_corr6_loc(maxvar))
19849 !(maxvar)
19850       allocate(gsccorc(3,-1:nres))
19851       allocate(gsccorx(3,-1:nres))
19852 !(3,maxres)
19853       allocate(gsccor_loc(-1:nres))
19854 !(maxres)
19855       allocate(gvdwx_scbase(3,-1:nres))
19856       allocate(gvdwc_scbase(3,-1:nres))
19857       allocate(gvdwx_pepbase(3,-1:nres))
19858       allocate(gvdwc_pepbase(3,-1:nres))
19859       allocate(gvdwx_scpho(3,-1:nres))
19860       allocate(gvdwc_scpho(3,-1:nres))
19861       allocate(gvdwc_peppho(3,-1:nres))
19862
19863       allocate(dtheta(3,2,-1:nres))
19864 !(3,2,maxres)
19865       allocate(gscloc(3,-1:nres))
19866       allocate(gsclocx(3,-1:nres))
19867 !(3,maxres)
19868       allocate(dphi(3,3,-1:nres))
19869       allocate(dalpha(3,3,-1:nres))
19870       allocate(domega(3,3,-1:nres))
19871 !(3,3,maxres)
19872 !      common /deriv_scloc/
19873       allocate(dXX_C1tab(3,nres))
19874       allocate(dYY_C1tab(3,nres))
19875       allocate(dZZ_C1tab(3,nres))
19876       allocate(dXX_Ctab(3,nres))
19877       allocate(dYY_Ctab(3,nres))
19878       allocate(dZZ_Ctab(3,nres))
19879       allocate(dXX_XYZtab(3,nres))
19880       allocate(dYY_XYZtab(3,nres))
19881       allocate(dZZ_XYZtab(3,nres))
19882 !(3,maxres)
19883 !      common /mpgrad/
19884       allocate(jgrad_start(nres))
19885       allocate(jgrad_end(nres))
19886 !(maxres)
19887 !----------------------
19888
19889 !      common /indices/
19890       allocate(ibond_displ(0:nfgtasks-1))
19891       allocate(ibond_count(0:nfgtasks-1))
19892       allocate(ithet_displ(0:nfgtasks-1))
19893       allocate(ithet_count(0:nfgtasks-1))
19894       allocate(iphi_displ(0:nfgtasks-1))
19895       allocate(iphi_count(0:nfgtasks-1))
19896       allocate(iphi1_displ(0:nfgtasks-1))
19897       allocate(iphi1_count(0:nfgtasks-1))
19898       allocate(ivec_displ(0:nfgtasks-1))
19899       allocate(ivec_count(0:nfgtasks-1))
19900       allocate(iset_displ(0:nfgtasks-1))
19901       allocate(iset_count(0:nfgtasks-1))
19902       allocate(iint_count(0:nfgtasks-1))
19903       allocate(iint_displ(0:nfgtasks-1))
19904 !(0:max_fg_procs-1)
19905 !----------------------
19906 ! common.MD
19907 !      common /mdgrad/
19908       allocate(gcart(3,-1:nres))
19909       allocate(gxcart(3,-1:nres))
19910 !(3,0:MAXRES)
19911       allocate(gradcag(3,-1:nres))
19912       allocate(gradxag(3,-1:nres))
19913 !(3,MAXRES)
19914 !      common /back_constr/
19915 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19916       allocate(dutheta(nres))
19917       allocate(dugamma(nres))
19918 !(maxres)
19919       allocate(duscdiff(3,nres))
19920       allocate(duscdiffx(3,nres))
19921 !(3,maxres)
19922 !el i io:read_fragments
19923 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19924 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19925 !      common /qmeas/
19926 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19927 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19928       allocate(mset(0:nprocs))  !(maxprocs/20)
19929       mset(:)=0
19930 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19931 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19932       allocate(dUdconst(3,0:nres))
19933       allocate(dUdxconst(3,0:nres))
19934       allocate(dqwol(3,0:nres))
19935       allocate(dxqwol(3,0:nres))
19936 !(3,0:MAXRES)
19937 !----------------------
19938 ! common.sbridge
19939 !      common /sbridge/ in io_common: read_bridge
19940 !el    allocate((:),allocatable :: iss      !(maxss)
19941 !      common /links/  in io_common: read_bridge
19942 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19943 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19944 !      common /dyn_ssbond/
19945 ! and side-chain vectors in theta or phi.
19946       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19947 !(maxres,maxres)
19948 !      do i=1,nres
19949 !        do j=i+1,nres
19950       dyn_ssbond_ij(:,:)=1.0d300
19951 !        enddo
19952 !      enddo
19953
19954 !      if (nss.gt.0) then
19955         allocate(idssb(maxdim),jdssb(maxdim))
19956 !        allocate(newihpb(nss),newjhpb(nss))
19957 !(maxdim)
19958 !      endif
19959       allocate(ishield_list(nres))
19960       allocate(shield_list(50,nres))
19961       allocate(dyn_ss_mask(nres))
19962       allocate(fac_shield(nres))
19963       allocate(enetube(nres*2))
19964       allocate(enecavtube(nres*2))
19965
19966 !(maxres)
19967       dyn_ss_mask(:)=.false.
19968 !----------------------
19969 ! common.sccor
19970 ! Parameters of the SCCOR term
19971 !      common/sccor/
19972 !el in io_conf: parmread
19973 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19974 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19975 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19976 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19977 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19978 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19979 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19980 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19981 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
19982 !----------------
19983       allocate(gloc_sc(3,0:2*nres,0:10))
19984 !(3,0:maxres2,10)maxres2=2*maxres
19985       allocate(dcostau(3,3,3,2*nres))
19986       allocate(dsintau(3,3,3,2*nres))
19987       allocate(dtauangle(3,3,3,2*nres))
19988       allocate(dcosomicron(3,3,3,2*nres))
19989       allocate(domicron(3,3,3,2*nres))
19990 !(3,3,3,maxres2)maxres2=2*maxres
19991 !----------------------
19992 ! common.var
19993 !      common /restr/
19994       allocate(varall(maxvar))
19995 !(maxvar)(maxvar=6*maxres)
19996       allocate(mask_theta(nres))
19997       allocate(mask_phi(nres))
19998       allocate(mask_side(nres))
19999 !(maxres)
20000 !----------------------
20001 ! common.vectors
20002 !      common /vectors/
20003       allocate(uy(3,nres))
20004       allocate(uz(3,nres))
20005 !(3,maxres)
20006       allocate(uygrad(3,3,2,nres))
20007       allocate(uzgrad(3,3,2,nres))
20008 !(3,3,2,maxres)
20009
20010       return
20011       end subroutine alloc_ener_arrays
20012 !-----------------------------------------------------------------
20013       subroutine ebond_nucl(estr_nucl)
20014 !c
20015 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20016 !c
20017
20018       real(kind=8),dimension(3) :: u,ud
20019       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20020       real(kind=8) :: estr_nucl,diff
20021       integer :: iti,i,j,k,nbi
20022       estr_nucl=0.0d0
20023 !C      print *,"I enter ebond"
20024       if (energy_dec) &
20025       write (iout,*) "ibondp_start,ibondp_end",&
20026        ibondp_nucl_start,ibondp_nucl_end
20027       do i=ibondp_nucl_start,ibondp_nucl_end
20028         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20029          itype(i,2).eq.ntyp1_molec(2)) cycle
20030 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20031 !          do j=1,3
20032 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20033 !     &      *dc(j,i-1)/vbld(i)
20034 !          enddo
20035 !          if (energy_dec) write(iout,*)
20036 !     &       "estr1",i,vbld(i),distchainmax,
20037 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20038
20039           diff = vbld(i)-vbldp0_nucl
20040           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20041           vbldp0_nucl,diff,AKP_nucl*diff*diff
20042           estr_nucl=estr_nucl+diff*diff
20043 !          print *,estr_nucl
20044           do j=1,3
20045             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20046           enddo
20047 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20048       enddo
20049       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20050 !      print *,"partial sum", estr_nucl,AKP_nucl
20051
20052       if (energy_dec) &
20053       write (iout,*) "ibondp_start,ibondp_end",&
20054        ibond_nucl_start,ibond_nucl_end
20055
20056       do i=ibond_nucl_start,ibond_nucl_end
20057 !C        print *, "I am stuck",i
20058         iti=itype(i,2)
20059         if (iti.eq.ntyp1_molec(2)) cycle
20060           nbi=nbondterm_nucl(iti)
20061 !C        print *,iti,nbi
20062           if (nbi.eq.1) then
20063             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20064
20065             if (energy_dec) &
20066            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20067            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20068             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20069 !            print *,estr_nucl
20070             do j=1,3
20071               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20072             enddo
20073           else
20074             do j=1,nbi
20075               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20076               ud(j)=aksc_nucl(j,iti)*diff
20077               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20078             enddo
20079             uprod=u(1)
20080             do j=2,nbi
20081               uprod=uprod*u(j)
20082             enddo
20083             usum=0.0d0
20084             usumsqder=0.0d0
20085             do j=1,nbi
20086               uprod1=1.0d0
20087               uprod2=1.0d0
20088               do k=1,nbi
20089                 if (k.ne.j) then
20090                   uprod1=uprod1*u(k)
20091                   uprod2=uprod2*u(k)*u(k)
20092                 endif
20093               enddo
20094               usum=usum+uprod1
20095               usumsqder=usumsqder+ud(j)*uprod2
20096             enddo
20097             estr_nucl=estr_nucl+uprod/usum
20098             do j=1,3
20099              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20100             enddo
20101         endif
20102       enddo
20103 !C      print *,"I am about to leave ebond"
20104       return
20105       end subroutine ebond_nucl
20106
20107 !-----------------------------------------------------------------------------
20108       subroutine ebend_nucl(etheta_nucl)
20109       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20110       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20111       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20112       logical :: lprn=.false., lprn1=.false.
20113 !el local variables
20114       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20115       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20116       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20117 ! local variables for constrains
20118       real(kind=8) :: difi,thetiii
20119        integer itheta
20120       etheta_nucl=0.0D0
20121 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20122       do i=ithet_nucl_start,ithet_nucl_end
20123         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20124         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20125         (itype(i,2).eq.ntyp1_molec(2))) cycle
20126         dethetai=0.0d0
20127         dephii=0.0d0
20128         dephii1=0.0d0
20129         theti2=0.5d0*theta(i)
20130         ityp2=ithetyp_nucl(itype(i-1,2))
20131         do k=1,nntheterm_nucl
20132           coskt(k)=dcos(k*theti2)
20133           sinkt(k)=dsin(k*theti2)
20134         enddo
20135         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20136 #ifdef OSF
20137           phii=phi(i)
20138           if (phii.ne.phii) phii=150.0
20139 #else
20140           phii=phi(i)
20141 #endif
20142           ityp1=ithetyp_nucl(itype(i-2,2))
20143           do k=1,nsingle_nucl
20144             cosph1(k)=dcos(k*phii)
20145             sinph1(k)=dsin(k*phii)
20146           enddo
20147         else
20148           phii=0.0d0
20149           ityp1=nthetyp_nucl+1
20150           do k=1,nsingle_nucl
20151             cosph1(k)=0.0d0
20152             sinph1(k)=0.0d0
20153           enddo
20154         endif
20155
20156         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20157 #ifdef OSF
20158           phii1=phi(i+1)
20159           if (phii1.ne.phii1) phii1=150.0
20160           phii1=pinorm(phii1)
20161 #else
20162           phii1=phi(i+1)
20163 #endif
20164           ityp3=ithetyp_nucl(itype(i,2))
20165           do k=1,nsingle_nucl
20166             cosph2(k)=dcos(k*phii1)
20167             sinph2(k)=dsin(k*phii1)
20168           enddo
20169         else
20170           phii1=0.0d0
20171           ityp3=nthetyp_nucl+1
20172           do k=1,nsingle_nucl
20173             cosph2(k)=0.0d0
20174             sinph2(k)=0.0d0
20175           enddo
20176         endif
20177         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20178         do k=1,ndouble_nucl
20179           do l=1,k-1
20180             ccl=cosph1(l)*cosph2(k-l)
20181             ssl=sinph1(l)*sinph2(k-l)
20182             scl=sinph1(l)*cosph2(k-l)
20183             csl=cosph1(l)*sinph2(k-l)
20184             cosph1ph2(l,k)=ccl-ssl
20185             cosph1ph2(k,l)=ccl+ssl
20186             sinph1ph2(l,k)=scl+csl
20187             sinph1ph2(k,l)=scl-csl
20188           enddo
20189         enddo
20190         if (lprn) then
20191         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20192          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20193         write (iout,*) "coskt and sinkt",nntheterm_nucl
20194         do k=1,nntheterm_nucl
20195           write (iout,*) k,coskt(k),sinkt(k)
20196         enddo
20197         endif
20198         do k=1,ntheterm_nucl
20199           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20200           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20201            *coskt(k)
20202           if (lprn)&
20203          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20204           " ethetai",ethetai
20205         enddo
20206         if (lprn) then
20207         write (iout,*) "cosph and sinph"
20208         do k=1,nsingle_nucl
20209           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20210         enddo
20211         write (iout,*) "cosph1ph2 and sinph2ph2"
20212         do k=2,ndouble_nucl
20213           do l=1,k-1
20214             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20215               sinph1ph2(l,k),sinph1ph2(k,l)
20216           enddo
20217         enddo
20218         write(iout,*) "ethetai",ethetai
20219         endif
20220         do m=1,ntheterm2_nucl
20221           do k=1,nsingle_nucl
20222             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20223               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20224               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20225               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20226             ethetai=ethetai+sinkt(m)*aux
20227             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20228             dephii=dephii+k*sinkt(m)*(&
20229                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20230                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20231             dephii1=dephii1+k*sinkt(m)*(&
20232                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20233                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20234             if (lprn) &
20235            write (iout,*) "m",m," k",k," bbthet",&
20236               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20237               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20238               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20239               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20240           enddo
20241         enddo
20242         if (lprn) &
20243         write(iout,*) "ethetai",ethetai
20244         do m=1,ntheterm3_nucl
20245           do k=2,ndouble_nucl
20246             do l=1,k-1
20247               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20248                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20249                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20250                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20251               ethetai=ethetai+sinkt(m)*aux
20252               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20253               dephii=dephii+l*sinkt(m)*(&
20254                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20255                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20256                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20257                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20258               dephii1=dephii1+(k-l)*sinkt(m)*( &
20259                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20260                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20261                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20262                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20263               if (lprn) then
20264               write (iout,*) "m",m," k",k," l",l," ffthet", &
20265                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20266                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20267                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20268                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20269               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20270                  cosph1ph2(k,l)*sinkt(m),&
20271                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20272               endif
20273             enddo
20274           enddo
20275         enddo
20276 10      continue
20277         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20278         i,theta(i)*rad2deg,phii*rad2deg, &
20279         phii1*rad2deg,ethetai
20280         etheta_nucl=etheta_nucl+ethetai
20281 !        print *,i,"partial sum",etheta_nucl
20282         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20283         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20284         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20285       enddo
20286       return
20287       end subroutine ebend_nucl
20288 !----------------------------------------------------
20289       subroutine etor_nucl(etors_nucl)
20290 !      implicit real*8 (a-h,o-z)
20291 !      include 'DIMENSIONS'
20292 !      include 'COMMON.VAR'
20293 !      include 'COMMON.GEO'
20294 !      include 'COMMON.LOCAL'
20295 !      include 'COMMON.TORSION'
20296 !      include 'COMMON.INTERACT'
20297 !      include 'COMMON.DERIV'
20298 !      include 'COMMON.CHAIN'
20299 !      include 'COMMON.NAMES'
20300 !      include 'COMMON.IOUNITS'
20301 !      include 'COMMON.FFIELD'
20302 !      include 'COMMON.TORCNSTR'
20303 !      include 'COMMON.CONTROL'
20304       real(kind=8) :: etors_nucl,edihcnstr
20305       logical :: lprn
20306 !el local variables
20307       integer :: i,j,iblock,itori,itori1
20308       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20309                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20310 ! Set lprn=.true. for debugging
20311       lprn=.false.
20312 !     lprn=.true.
20313       etors_nucl=0.0D0
20314 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20315       do i=iphi_nucl_start,iphi_nucl_end
20316         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20317              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20318              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20319         etors_ii=0.0D0
20320         itori=itortyp_nucl(itype(i-2,2))
20321         itori1=itortyp_nucl(itype(i-1,2))
20322         phii=phi(i)
20323 !         print *,i,itori,itori1
20324         gloci=0.0D0
20325 !C Regular cosine and sine terms
20326         do j=1,nterm_nucl(itori,itori1)
20327           v1ij=v1_nucl(j,itori,itori1)
20328           v2ij=v2_nucl(j,itori,itori1)
20329           cosphi=dcos(j*phii)
20330           sinphi=dsin(j*phii)
20331           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20332           if (energy_dec) etors_ii=etors_ii+&
20333                      v1ij*cosphi+v2ij*sinphi
20334           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20335         enddo
20336 !C Lorentz terms
20337 !C                         v1
20338 !C  E = SUM ----------------------------------- - v1
20339 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20340 !C
20341         cosphi=dcos(0.5d0*phii)
20342         sinphi=dsin(0.5d0*phii)
20343         do j=1,nlor_nucl(itori,itori1)
20344           vl1ij=vlor1_nucl(j,itori,itori1)
20345           vl2ij=vlor2_nucl(j,itori,itori1)
20346           vl3ij=vlor3_nucl(j,itori,itori1)
20347           pom=vl2ij*cosphi+vl3ij*sinphi
20348           pom1=1.0d0/(pom*pom+1.0d0)
20349           etors_nucl=etors_nucl+vl1ij*pom1
20350           if (energy_dec) etors_ii=etors_ii+ &
20351                      vl1ij*pom1
20352           pom=-pom*pom1*pom1
20353           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20354         enddo
20355 !C Subtract the constant term
20356         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20357           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20358               'etor',i,etors_ii-v0_nucl(itori,itori1)
20359         if (lprn) &
20360        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20361        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20362        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20363         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20364 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20365       enddo
20366       return
20367       end subroutine etor_nucl
20368 !------------------------------------------------------------
20369       subroutine epp_nucl_sub(evdw1,ees)
20370 !C
20371 !C This subroutine calculates the average interaction energy and its gradient
20372 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20373 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20374 !C The potential depends both on the distance of peptide-group centers and on
20375 !C the orientation of the CA-CA virtual bonds.
20376 !C
20377       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20378       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20379       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20380                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20381                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20382       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20383                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20384       integer xshift,yshift,zshift
20385       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20386       real(kind=8) :: ees,eesij
20387 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20388       real(kind=8) scal_el /0.5d0/
20389       t_eelecij=0.0d0
20390       ees=0.0D0
20391       evdw1=0.0D0
20392       ind=0
20393 !c
20394 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20395 !c
20396 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20397       do i=iatel_s_nucl,iatel_e_nucl
20398         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20399         dxi=dc(1,i)
20400         dyi=dc(2,i)
20401         dzi=dc(3,i)
20402         dx_normi=dc_norm(1,i)
20403         dy_normi=dc_norm(2,i)
20404         dz_normi=dc_norm(3,i)
20405         xmedi=c(1,i)+0.5d0*dxi
20406         ymedi=c(2,i)+0.5d0*dyi
20407         zmedi=c(3,i)+0.5d0*dzi
20408           xmedi=dmod(xmedi,boxxsize)
20409           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20410           ymedi=dmod(ymedi,boxysize)
20411           if (ymedi.lt.0) ymedi=ymedi+boxysize
20412           zmedi=dmod(zmedi,boxzsize)
20413           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20414
20415         do j=ielstart_nucl(i),ielend_nucl(i)
20416           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20417           ind=ind+1
20418           dxj=dc(1,j)
20419           dyj=dc(2,j)
20420           dzj=dc(3,j)
20421 !          xj=c(1,j)+0.5D0*dxj-xmedi
20422 !          yj=c(2,j)+0.5D0*dyj-ymedi
20423 !          zj=c(3,j)+0.5D0*dzj-zmedi
20424           xj=c(1,j)+0.5D0*dxj
20425           yj=c(2,j)+0.5D0*dyj
20426           zj=c(3,j)+0.5D0*dzj
20427           xj=mod(xj,boxxsize)
20428           if (xj.lt.0) xj=xj+boxxsize
20429           yj=mod(yj,boxysize)
20430           if (yj.lt.0) yj=yj+boxysize
20431           zj=mod(zj,boxzsize)
20432           if (zj.lt.0) zj=zj+boxzsize
20433       isubchap=0
20434       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20435       xj_safe=xj
20436       yj_safe=yj
20437       zj_safe=zj
20438       do xshift=-1,1
20439       do yshift=-1,1
20440       do zshift=-1,1
20441           xj=xj_safe+xshift*boxxsize
20442           yj=yj_safe+yshift*boxysize
20443           zj=zj_safe+zshift*boxzsize
20444           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20445           if(dist_temp.lt.dist_init) then
20446             dist_init=dist_temp
20447             xj_temp=xj
20448             yj_temp=yj
20449             zj_temp=zj
20450             isubchap=1
20451           endif
20452        enddo
20453        enddo
20454        enddo
20455        if (isubchap.eq.1) then
20456 !C          print *,i,j
20457           xj=xj_temp-xmedi
20458           yj=yj_temp-ymedi
20459           zj=zj_temp-zmedi
20460        else
20461           xj=xj_safe-xmedi
20462           yj=yj_safe-ymedi
20463           zj=zj_safe-zmedi
20464        endif
20465
20466           rij=xj*xj+yj*yj+zj*zj
20467 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20468           fac=(r0pp**2/rij)**3
20469           ev1=epspp*fac*fac
20470           ev2=epspp*fac
20471           evdw1ij=ev1-2*ev2
20472           fac=(-ev1-evdw1ij)/rij
20473 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20474           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20475           evdw1=evdw1+evdw1ij
20476 !C
20477 !C Calculate contributions to the Cartesian gradient.
20478 !C
20479           ggg(1)=fac*xj
20480           ggg(2)=fac*yj
20481           ggg(3)=fac*zj
20482           do k=1,3
20483             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20484             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20485           enddo
20486 !c phoshate-phosphate electrostatic interactions
20487           rij=dsqrt(rij)
20488           fac=1.0d0/rij
20489           eesij=dexp(-BEES*rij)*fac
20490 !          write (2,*)"fac",fac," eesijpp",eesij
20491           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20492           ees=ees+eesij
20493 !c          fac=-eesij*fac
20494           fac=-(fac+BEES)*eesij*fac
20495           ggg(1)=fac*xj
20496           ggg(2)=fac*yj
20497           ggg(3)=fac*zj
20498 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20499 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20500 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20501           do k=1,3
20502             gelpp(k,i)=gelpp(k,i)-ggg(k)
20503             gelpp(k,j)=gelpp(k,j)+ggg(k)
20504           enddo
20505         enddo ! j
20506       enddo   ! i
20507 !c      ees=332.0d0*ees
20508       ees=AEES*ees
20509       do i=nnt,nct
20510 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20511         do k=1,3
20512           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20513 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20514           gelpp(k,i)=AEES*gelpp(k,i)
20515         enddo
20516 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20517       enddo
20518 !c      write (2,*) "total EES",ees
20519       return
20520       end subroutine epp_nucl_sub
20521 !---------------------------------------------------------------------
20522       subroutine epsb(evdwpsb,eelpsb)
20523 !      use comm_locel
20524 !C
20525 !C This subroutine calculates the excluded-volume interaction energy between
20526 !C peptide-group centers and side chains and its gradient in virtual-bond and
20527 !C side-chain vectors.
20528 !C
20529       real(kind=8),dimension(3):: ggg
20530       integer :: i,iint,j,k,iteli,itypj,subchap
20531       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20532                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20533       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20534                     dist_temp, dist_init
20535       integer xshift,yshift,zshift
20536
20537 !cd    print '(a)','Enter ESCP'
20538 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20539       eelpsb=0.0d0
20540       evdwpsb=0.0d0
20541 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20542       do i=iatscp_s_nucl,iatscp_e_nucl
20543         if (itype(i,2).eq.ntyp1_molec(2) &
20544          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20545         xi=0.5D0*(c(1,i)+c(1,i+1))
20546         yi=0.5D0*(c(2,i)+c(2,i+1))
20547         zi=0.5D0*(c(3,i)+c(3,i+1))
20548           xi=mod(xi,boxxsize)
20549           if (xi.lt.0) xi=xi+boxxsize
20550           yi=mod(yi,boxysize)
20551           if (yi.lt.0) yi=yi+boxysize
20552           zi=mod(zi,boxzsize)
20553           if (zi.lt.0) zi=zi+boxzsize
20554
20555         do iint=1,nscp_gr_nucl(i)
20556
20557         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20558           itypj=itype(j,2)
20559           if (itypj.eq.ntyp1_molec(2)) cycle
20560 !C Uncomment following three lines for SC-p interactions
20561 !c         xj=c(1,nres+j)-xi
20562 !c         yj=c(2,nres+j)-yi
20563 !c         zj=c(3,nres+j)-zi
20564 !C Uncomment following three lines for Ca-p interactions
20565 !          xj=c(1,j)-xi
20566 !          yj=c(2,j)-yi
20567 !          zj=c(3,j)-zi
20568           xj=c(1,j)
20569           yj=c(2,j)
20570           zj=c(3,j)
20571           xj=mod(xj,boxxsize)
20572           if (xj.lt.0) xj=xj+boxxsize
20573           yj=mod(yj,boxysize)
20574           if (yj.lt.0) yj=yj+boxysize
20575           zj=mod(zj,boxzsize)
20576           if (zj.lt.0) zj=zj+boxzsize
20577       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20578       xj_safe=xj
20579       yj_safe=yj
20580       zj_safe=zj
20581       subchap=0
20582       do xshift=-1,1
20583       do yshift=-1,1
20584       do zshift=-1,1
20585           xj=xj_safe+xshift*boxxsize
20586           yj=yj_safe+yshift*boxysize
20587           zj=zj_safe+zshift*boxzsize
20588           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20589           if(dist_temp.lt.dist_init) then
20590             dist_init=dist_temp
20591             xj_temp=xj
20592             yj_temp=yj
20593             zj_temp=zj
20594             subchap=1
20595           endif
20596        enddo
20597        enddo
20598        enddo
20599        if (subchap.eq.1) then
20600           xj=xj_temp-xi
20601           yj=yj_temp-yi
20602           zj=zj_temp-zi
20603        else
20604           xj=xj_safe-xi
20605           yj=yj_safe-yi
20606           zj=zj_safe-zi
20607        endif
20608
20609           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20610           fac=rrij**expon2
20611           e1=fac*fac*aad_nucl(itypj)
20612           e2=fac*bad_nucl(itypj)
20613           if (iabs(j-i) .le. 2) then
20614             e1=scal14*e1
20615             e2=scal14*e2
20616           endif
20617           evdwij=e1+e2
20618           evdwpsb=evdwpsb+evdwij
20619           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20620              'evdw2',i,j,evdwij,"tu4"
20621 !C
20622 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20623 !C
20624           fac=-(evdwij+e1)*rrij
20625           ggg(1)=xj*fac
20626           ggg(2)=yj*fac
20627           ggg(3)=zj*fac
20628           do k=1,3
20629             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20630             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20631           enddo
20632         enddo
20633
20634         enddo ! iint
20635       enddo ! i
20636       do i=1,nct
20637         do j=1,3
20638           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20639           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20640         enddo
20641       enddo
20642       return
20643       end subroutine epsb
20644
20645 !------------------------------------------------------
20646       subroutine esb_gb(evdwsb,eelsb)
20647       use comm_locel
20648       use calc_data_nucl
20649       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20650       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20651       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20652       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20653                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20654       integer :: ii
20655       logical lprn
20656       evdw=0.0D0
20657       eelsb=0.0d0
20658       ecorr=0.0d0
20659       evdwsb=0.0D0
20660       lprn=.false.
20661       ind=0
20662 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20663       do i=iatsc_s_nucl,iatsc_e_nucl
20664         num_conti=0
20665         num_conti2=0
20666         itypi=itype(i,2)
20667 !        PRINT *,"I=",i,itypi
20668         if (itypi.eq.ntyp1_molec(2)) cycle
20669         itypi1=itype(i+1,2)
20670         xi=c(1,nres+i)
20671         yi=c(2,nres+i)
20672         zi=c(3,nres+i)
20673           xi=dmod(xi,boxxsize)
20674           if (xi.lt.0) xi=xi+boxxsize
20675           yi=dmod(yi,boxysize)
20676           if (yi.lt.0) yi=yi+boxysize
20677           zi=dmod(zi,boxzsize)
20678           if (zi.lt.0) zi=zi+boxzsize
20679
20680         dxi=dc_norm(1,nres+i)
20681         dyi=dc_norm(2,nres+i)
20682         dzi=dc_norm(3,nres+i)
20683         dsci_inv=vbld_inv(i+nres)
20684 !C
20685 !C Calculate SC interaction energy.
20686 !C
20687         do iint=1,nint_gr_nucl(i)
20688 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20689           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20690             ind=ind+1
20691 !            print *,"JESTEM"
20692             itypj=itype(j,2)
20693             if (itypj.eq.ntyp1_molec(2)) cycle
20694             dscj_inv=vbld_inv(j+nres)
20695             sig0ij=sigma_nucl(itypi,itypj)
20696             chi1=chi_nucl(itypi,itypj)
20697             chi2=chi_nucl(itypj,itypi)
20698             chi12=chi1*chi2
20699             chip1=chip_nucl(itypi,itypj)
20700             chip2=chip_nucl(itypj,itypi)
20701             chip12=chip1*chip2
20702 !            xj=c(1,nres+j)-xi
20703 !            yj=c(2,nres+j)-yi
20704 !            zj=c(3,nres+j)-zi
20705            xj=c(1,nres+j)
20706            yj=c(2,nres+j)
20707            zj=c(3,nres+j)
20708           xj=dmod(xj,boxxsize)
20709           if (xj.lt.0) xj=xj+boxxsize
20710           yj=dmod(yj,boxysize)
20711           if (yj.lt.0) yj=yj+boxysize
20712           zj=dmod(zj,boxzsize)
20713           if (zj.lt.0) zj=zj+boxzsize
20714       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20715       xj_safe=xj
20716       yj_safe=yj
20717       zj_safe=zj
20718       subchap=0
20719       do xshift=-1,1
20720       do yshift=-1,1
20721       do zshift=-1,1
20722           xj=xj_safe+xshift*boxxsize
20723           yj=yj_safe+yshift*boxysize
20724           zj=zj_safe+zshift*boxzsize
20725           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20726           if(dist_temp.lt.dist_init) then
20727             dist_init=dist_temp
20728             xj_temp=xj
20729             yj_temp=yj
20730             zj_temp=zj
20731             subchap=1
20732           endif
20733        enddo
20734        enddo
20735        enddo
20736        if (subchap.eq.1) then
20737           xj=xj_temp-xi
20738           yj=yj_temp-yi
20739           zj=zj_temp-zi
20740        else
20741           xj=xj_safe-xi
20742           yj=yj_safe-yi
20743           zj=zj_safe-zi
20744        endif
20745
20746             dxj=dc_norm(1,nres+j)
20747             dyj=dc_norm(2,nres+j)
20748             dzj=dc_norm(3,nres+j)
20749             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20750             rij=dsqrt(rrij)
20751 !C Calculate angle-dependent terms of energy and contributions to their
20752 !C derivatives.
20753             erij(1)=xj*rij
20754             erij(2)=yj*rij
20755             erij(3)=zj*rij
20756             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20757             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20758             om12=dxi*dxj+dyi*dyj+dzi*dzj
20759             call sc_angular_nucl
20760             sigsq=1.0D0/sigsq
20761             sig=sig0ij*dsqrt(sigsq)
20762             rij_shift=1.0D0/rij-sig+sig0ij
20763 !            print *,rij_shift,"rij_shift"
20764 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20765 !c     &       " rij_shift",rij_shift
20766             if (rij_shift.le.0.0D0) then
20767               evdw=1.0D20
20768               return
20769             endif
20770             sigder=-sig*sigsq
20771 !c---------------------------------------------------------------
20772             rij_shift=1.0D0/rij_shift
20773             fac=rij_shift**expon
20774             e1=fac*fac*aa_nucl(itypi,itypj)
20775             e2=fac*bb_nucl(itypi,itypj)
20776             evdwij=eps1*eps2rt*(e1+e2)
20777 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20778 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20779             eps2der=evdwij
20780             evdwij=evdwij*eps2rt
20781             evdwsb=evdwsb+evdwij
20782             if (lprn) then
20783             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
20784             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
20785             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20786              restyp(itypi,2),i,restyp(itypj,2),j, &
20787              epsi,sigm,chi1,chi2,chip1,chip2, &
20788              eps1,eps2rt**2,sig,sig0ij, &
20789              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20790             evdwij
20791             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20792             endif
20793
20794             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20795                              'evdw',i,j,evdwij,"tu3"
20796
20797
20798 !C Calculate gradient components.
20799             e1=e1*eps1*eps2rt**2
20800             fac=-expon*(e1+evdwij)*rij_shift
20801             sigder=fac*sigder
20802             fac=rij*fac
20803 !c            fac=0.0d0
20804 !C Calculate the radial part of the gradient
20805             gg(1)=xj*fac
20806             gg(2)=yj*fac
20807             gg(3)=zj*fac
20808 !C Calculate angular part of the gradient.
20809             call sc_grad_nucl
20810             call eelsbij(eelij,num_conti2)
20811             if (energy_dec .and. &
20812            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20813           write (istat,'(e14.5)') evdwij
20814             eelsb=eelsb+eelij
20815           enddo      ! j
20816         enddo        ! iint
20817         num_cont_hb(i)=num_conti2
20818       enddo          ! i
20819 !c      write (iout,*) "Number of loop steps in EGB:",ind
20820 !cccc      energy_dec=.false.
20821       return
20822       end subroutine esb_gb
20823 !-------------------------------------------------------------------------------
20824       subroutine eelsbij(eesij,num_conti2)
20825       use comm_locel
20826       use calc_data_nucl
20827       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20828       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20829       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20830                     dist_temp, dist_init,rlocshield,fracinbuf
20831       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20832
20833 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20834       real(kind=8) scal_el /0.5d0/
20835       integer :: iteli,itelj,kkk,kkll,m,isubchap
20836       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20837       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20838       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20839                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20840                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20841                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20842                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20843                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20844                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20845                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20846       ind=ind+1
20847       itypi=itype(i,2)
20848       itypj=itype(j,2)
20849 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20850       ael6i=ael6_nucl(itypi,itypj)
20851       ael3i=ael3_nucl(itypi,itypj)
20852       ael63i=ael63_nucl(itypi,itypj)
20853       ael32i=ael32_nucl(itypi,itypj)
20854 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20855 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20856       dxj=dc(1,j+nres)
20857       dyj=dc(2,j+nres)
20858       dzj=dc(3,j+nres)
20859       dx_normi=dc_norm(1,i+nres)
20860       dy_normi=dc_norm(2,i+nres)
20861       dz_normi=dc_norm(3,i+nres)
20862       dx_normj=dc_norm(1,j+nres)
20863       dy_normj=dc_norm(2,j+nres)
20864       dz_normj=dc_norm(3,j+nres)
20865 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20866 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20867 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20868       if (ipot_nucl.ne.2) then
20869         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20870         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20871         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20872       else
20873         cosa=om12
20874         cosb=om1
20875         cosg=om2
20876       endif
20877       r3ij=rij*rrij
20878       r6ij=r3ij*r3ij
20879       fac=cosa-3.0D0*cosb*cosg
20880       facfac=fac*fac
20881       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20882       fac3=ael6i*r6ij
20883       fac4=ael3i*r3ij
20884       fac5=ael63i*r6ij
20885       fac6=ael32i*r6ij
20886 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20887 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20888       el1=fac3*(4.0D0+facfac-fac1)
20889       el2=fac4*fac
20890       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20891       el4=fac6*facfac
20892       eesij=el1+el2+el3+el4
20893 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20894       ees0ij=4.0D0+facfac-fac1
20895
20896       if (energy_dec) then
20897           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20898           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20899            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20900            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20901            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20902           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20903       endif
20904
20905 !C
20906 !C Calculate contributions to the Cartesian gradient.
20907 !C
20908       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20909       fac1=fac
20910 !c      erij(1)=xj*rmij
20911 !c      erij(2)=yj*rmij
20912 !c      erij(3)=zj*rmij
20913 !*
20914 !* Radial derivatives. First process both termini of the fragment (i,j)
20915 !*
20916       ggg(1)=facel*xj
20917       ggg(2)=facel*yj
20918       ggg(3)=facel*zj
20919       do k=1,3
20920         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20921         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20922         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20923         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20924       enddo
20925 !*
20926 !* Angular part
20927 !*
20928       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20929       fac4=-3.0D0*fac4
20930       fac3=-6.0D0*fac3
20931       fac5= 6.0d0*fac5
20932       fac6=-6.0d0*fac6
20933       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20934        fac6*fac1*cosg
20935       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20936        fac6*fac1*cosb
20937       do k=1,3
20938         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20939         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20940       enddo
20941       do k=1,3
20942         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20943       enddo
20944       do k=1,3
20945         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20946              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20947              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20948         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20949              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20950              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20951         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20952         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20953       enddo
20954 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
20955        IF ( j.gt.i+1 .and.&
20956           num_conti.le.maxconts) THEN
20957 !C
20958 !C Calculate the contact function. The ith column of the array JCONT will
20959 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20960 !C greater than I). The arrays FACONT and GACONT will contain the values of
20961 !C the contact function and its derivative.
20962         r0ij=2.20D0*sigma(itypi,itypj)
20963 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20964         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20965 !c        write (2,*) "fcont",fcont
20966         if (fcont.gt.0.0D0) then
20967           num_conti=num_conti+1
20968           num_conti2=num_conti2+1
20969
20970           if (num_conti.gt.maxconts) then
20971             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20972                           ' will skip next contacts for this conf.'
20973           else
20974             jcont_hb(num_conti,i)=j
20975 !c            write (iout,*) "num_conti",num_conti,
20976 !c     &        " jcont_hb",jcont_hb(num_conti,i)
20977 !C Calculate contact energies
20978             cosa4=4.0D0*cosa
20979             wij=cosa-3.0D0*cosb*cosg
20980             cosbg1=cosb+cosg
20981             cosbg2=cosb-cosg
20982             fac3=dsqrt(-ael6i)*r3ij
20983 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
20984             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
20985             if (ees0tmp.gt.0) then
20986               ees0pij=dsqrt(ees0tmp)
20987             else
20988               ees0pij=0
20989             endif
20990             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
20991             if (ees0tmp.gt.0) then
20992               ees0mij=dsqrt(ees0tmp)
20993             else
20994               ees0mij=0
20995             endif
20996             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
20997             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
20998 !c            write (iout,*) "i",i," j",j,
20999 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21000             ees0pij1=fac3/ees0pij
21001             ees0mij1=fac3/ees0mij
21002             fac3p=-3.0D0*fac3*rrij
21003             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21004             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21005             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21006             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21007             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21008             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21009             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21010             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21011             ecosap=ecosa1+ecosa2
21012             ecosbp=ecosb1+ecosb2
21013             ecosgp=ecosg1+ecosg2
21014             ecosam=ecosa1-ecosa2
21015             ecosbm=ecosb1-ecosb2
21016             ecosgm=ecosg1-ecosg2
21017 !C End diagnostics
21018             facont_hb(num_conti,i)=fcont
21019             fprimcont=fprimcont/rij
21020             do k=1,3
21021               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21022               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21023             enddo
21024             gggp(1)=gggp(1)+ees0pijp*xj
21025             gggp(2)=gggp(2)+ees0pijp*yj
21026             gggp(3)=gggp(3)+ees0pijp*zj
21027             gggm(1)=gggm(1)+ees0mijp*xj
21028             gggm(2)=gggm(2)+ees0mijp*yj
21029             gggm(3)=gggm(3)+ees0mijp*zj
21030 !C Derivatives due to the contact function
21031             gacont_hbr(1,num_conti,i)=fprimcont*xj
21032             gacont_hbr(2,num_conti,i)=fprimcont*yj
21033             gacont_hbr(3,num_conti,i)=fprimcont*zj
21034             do k=1,3
21035 !c
21036 !c Gradient of the correlation terms
21037 !c
21038               gacontp_hb1(k,num_conti,i)= &
21039              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21040             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21041               gacontp_hb2(k,num_conti,i)= &
21042              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21043             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21044               gacontp_hb3(k,num_conti,i)=gggp(k)
21045               gacontm_hb1(k,num_conti,i)= &
21046              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21047             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21048               gacontm_hb2(k,num_conti,i)= &
21049              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21050             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21051               gacontm_hb3(k,num_conti,i)=gggm(k)
21052             enddo
21053           endif
21054         endif
21055       ENDIF
21056       return
21057       end subroutine eelsbij
21058 !------------------------------------------------------------------
21059       subroutine sc_grad_nucl
21060       use comm_locel
21061       use calc_data_nucl
21062       real(kind=8),dimension(3) :: dcosom1,dcosom2
21063       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21064       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21065       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21066       do k=1,3
21067         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21068         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21069       enddo
21070       do k=1,3
21071         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21072       enddo
21073       do k=1,3
21074         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21075                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21076                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21077         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21078                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21079                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21080       enddo
21081 !C
21082 !C Calculate the components of the gradient in DC and X
21083 !C
21084       do l=1,3
21085         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21086         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21087       enddo
21088       return
21089       end subroutine sc_grad_nucl
21090 !-----------------------------------------------------------------------
21091       subroutine esb(esbloc)
21092 !C Calculate the local energy of a side chain and its derivatives in the
21093 !C corresponding virtual-bond valence angles THETA and the spherical angles
21094 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21095 !C added by Urszula Kozlowska. 07/11/2007
21096 !C
21097       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21098       real(kind=8),dimension(9):: x
21099      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21100       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21101       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21102       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21103        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21104        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21105        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21106        integer::it,nlobit,i,j,k
21107 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21108       delta=0.02d0*pi
21109       esbloc=0.0D0
21110       do i=loc_start_nucl,loc_end_nucl
21111         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21112         costtab(i+1) =dcos(theta(i+1))
21113         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21114         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21115         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21116         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21117         cosfac=dsqrt(cosfac2)
21118         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21119         sinfac=dsqrt(sinfac2)
21120         it=itype(i,2)
21121         if (it.eq.10) goto 1
21122
21123 !c
21124 !C  Compute the axes of tghe local cartesian coordinates system; store in
21125 !c   x_prime, y_prime and z_prime
21126 !c
21127         do j=1,3
21128           x_prime(j) = 0.00
21129           y_prime(j) = 0.00
21130           z_prime(j) = 0.00
21131         enddo
21132 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21133 !C     &   dc_norm(3,i+nres)
21134         do j = 1,3
21135           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21136           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21137         enddo
21138         do j = 1,3
21139           z_prime(j) = -uz(j,i-1)
21140 !           z_prime(j)=0.0
21141         enddo
21142
21143         xx=0.0d0
21144         yy=0.0d0
21145         zz=0.0d0
21146         do j = 1,3
21147           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21148           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21149           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21150         enddo
21151
21152         xxtab(i)=xx
21153         yytab(i)=yy
21154         zztab(i)=zz
21155          it=itype(i,2)
21156         do j = 1,9
21157           x(j) = sc_parmin_nucl(j,it)
21158         enddo
21159 #ifdef CHECK_COORD
21160 !Cc diagnostics - remove later
21161         xx1 = dcos(alph(2))
21162         yy1 = dsin(alph(2))*dcos(omeg(2))
21163         zz1 = -dsin(alph(2))*dsin(omeg(2))
21164         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21165          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21166          xx1,yy1,zz1
21167 !C,"  --- ", xx_w,yy_w,zz_w
21168 !c end diagnostics
21169 #endif
21170         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21171         esbloc = esbloc + sumene
21172         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21173 !        print *,"enecomp",sumene,sumene2
21174 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21175 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21176 #ifdef DEBUG
21177         write (2,*) "x",(x(k),k=1,9)
21178 !C
21179 !C This section to check the numerical derivatives of the energy of ith side
21180 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21181 !C #define DEBUG in the code to turn it on.
21182 !C
21183         write (2,*) "sumene               =",sumene
21184         aincr=1.0d-7
21185         xxsave=xx
21186         xx=xx+aincr
21187         write (2,*) xx,yy,zz
21188         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21189         de_dxx_num=(sumenep-sumene)/aincr
21190         xx=xxsave
21191         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21192         yysave=yy
21193         yy=yy+aincr
21194         write (2,*) xx,yy,zz
21195         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21196         de_dyy_num=(sumenep-sumene)/aincr
21197         yy=yysave
21198         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21199         zzsave=zz
21200         zz=zz+aincr
21201         write (2,*) xx,yy,zz
21202         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21203         de_dzz_num=(sumenep-sumene)/aincr
21204         zz=zzsave
21205         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21206         costsave=cost2tab(i+1)
21207         sintsave=sint2tab(i+1)
21208         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21209         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21210         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21211         de_dt_num=(sumenep-sumene)/aincr
21212         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21213         cost2tab(i+1)=costsave
21214         sint2tab(i+1)=sintsave
21215 !C End of diagnostics section.
21216 #endif
21217 !C
21218 !C Compute the gradient of esc
21219 !C
21220         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21221         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21222         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21223         de_dtt=0.0d0
21224 #ifdef DEBUG
21225         write (2,*) "x",(x(k),k=1,9)
21226         write (2,*) "xx",xx," yy",yy," zz",zz
21227         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21228           " de_zz   ",de_zz," de_tt   ",de_tt
21229         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21230           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21231 #endif
21232 !C
21233        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21234        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21235        cosfac2xx=cosfac2*xx
21236        sinfac2yy=sinfac2*yy
21237        do k = 1,3
21238          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21239            vbld_inv(i+1)
21240          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21241            vbld_inv(i)
21242          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21243          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21244 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21245 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21246 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21247 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21248          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21249          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21250          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21251          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21252          dZZ_Ci1(k)=0.0d0
21253          dZZ_Ci(k)=0.0d0
21254          do j=1,3
21255            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21256            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21257          enddo
21258
21259          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21260          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21261          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21262 !c
21263          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21264          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21265        enddo
21266
21267        do k=1,3
21268          dXX_Ctab(k,i)=dXX_Ci(k)
21269          dXX_C1tab(k,i)=dXX_Ci1(k)
21270          dYY_Ctab(k,i)=dYY_Ci(k)
21271          dYY_C1tab(k,i)=dYY_Ci1(k)
21272          dZZ_Ctab(k,i)=dZZ_Ci(k)
21273          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21274          dXX_XYZtab(k,i)=dXX_XYZ(k)
21275          dYY_XYZtab(k,i)=dYY_XYZ(k)
21276          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21277        enddo
21278        do k = 1,3
21279 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21280 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21281 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21282 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21283 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21284 !c     &    dt_dci(k)
21285 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21286 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21287          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21288          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21289          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21290          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21291          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21292          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21293 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21294        enddo
21295 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21296 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21297
21298 !C to check gradient call subroutine check_grad
21299
21300     1 continue
21301       enddo
21302       return
21303       end subroutine esb
21304 !=-------------------------------------------------------
21305       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21306 !      implicit none
21307       real(kind=8),dimension(9):: x(9)
21308        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21309       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21310       integer i
21311 !c      write (2,*) "enesc"
21312 !c      write (2,*) "x",(x(i),i=1,9)
21313 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21314       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21315         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21316         + x(9)*yy*zz
21317       enesc_nucl=sumene
21318       return
21319       end function enesc_nucl
21320 !-----------------------------------------------------------------------------
21321       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21322 #ifdef MPI
21323       include 'mpif.h'
21324       integer,parameter :: max_cont=2000
21325       integer,parameter:: max_dim=2*(8*3+6)
21326       integer, parameter :: msglen1=max_cont*max_dim
21327       integer,parameter :: msglen2=2*msglen1
21328       integer source,CorrelType,CorrelID,Error
21329       real(kind=8) :: buffer(max_cont,max_dim)
21330       integer status(MPI_STATUS_SIZE)
21331       integer :: ierror,nbytes
21332 #endif
21333       real(kind=8),dimension(3):: gx(3),gx1(3)
21334       real(kind=8) :: time00
21335       logical lprn,ldone
21336       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21337       real(kind=8) ecorr,ecorr3
21338       integer :: n_corr,n_corr1,mm,msglen
21339 !C Set lprn=.true. for debugging
21340       lprn=.false.
21341       n_corr=0
21342       n_corr1=0
21343 #ifdef MPI
21344       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21345
21346       if (nfgtasks.le.1) goto 30
21347       if (lprn) then
21348         write (iout,'(a)') 'Contact function values:'
21349         do i=nnt,nct-1
21350           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21351          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21352          j=1,num_cont_hb(i))
21353         enddo
21354       endif
21355 !C Caution! Following code assumes that electrostatic interactions concerning
21356 !C a given atom are split among at most two processors!
21357       CorrelType=477
21358       CorrelID=fg_rank+1
21359       ldone=.false.
21360       do i=1,max_cont
21361         do j=1,max_dim
21362           buffer(i,j)=0.0D0
21363         enddo
21364       enddo
21365       mm=mod(fg_rank,2)
21366 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21367       if (mm) 20,20,10
21368    10 continue
21369 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21370       if (fg_rank.gt.0) then
21371 !C Send correlation contributions to the preceding processor
21372         msglen=msglen1
21373         nn=num_cont_hb(iatel_s_nucl)
21374         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21375 !c        write (*,*) 'The BUFFER array:'
21376 !c        do i=1,nn
21377 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21378 !c        enddo
21379         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21380           msglen=msglen2
21381           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21382 !C Clear the contacts of the atom passed to the neighboring processor
21383         nn=num_cont_hb(iatel_s_nucl+1)
21384 !c        do i=1,nn
21385 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21386 !c        enddo
21387             num_cont_hb(iatel_s_nucl)=0
21388         endif
21389 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21390 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21391 !cd   & ' msglen=',msglen
21392 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21393 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21394 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21395         time00=MPI_Wtime()
21396         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21397          CorrelType,FG_COMM,IERROR)
21398         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21399 !cd      write (iout,*) 'Processor ',fg_rank,
21400 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21401 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21402 !c        write (*,*) 'Processor ',fg_rank,
21403 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21404 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21405 !c        msglen=msglen1
21406       endif ! (fg_rank.gt.0)
21407       if (ldone) goto 30
21408       ldone=.true.
21409    20 continue
21410 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21411       if (fg_rank.lt.nfgtasks-1) then
21412 !C Receive correlation contributions from the next processor
21413         msglen=msglen1
21414         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21415 !cd      write (iout,*) 'Processor',fg_rank,
21416 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21417 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21418 !c        write (*,*) 'Processor',fg_rank,
21419 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21420 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21421         time00=MPI_Wtime()
21422         nbytes=-1
21423         do while (nbytes.le.0)
21424           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21425           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21426         enddo
21427 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21428         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21429          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21430         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21431 !c        write (*,*) 'Processor',fg_rank,
21432 !c     &' has received correlation contribution from processor',fg_rank+1,
21433 !c     & ' msglen=',msglen,' nbytes=',nbytes
21434 !c        write (*,*) 'The received BUFFER array:'
21435 !c        do i=1,max_cont
21436 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21437 !c        enddo
21438         if (msglen.eq.msglen1) then
21439           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21440         else if (msglen.eq.msglen2)  then
21441           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21442           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21443         else
21444           write (iout,*) &
21445       'ERROR!!!! message length changed while processing correlations.'
21446           write (*,*) &
21447       'ERROR!!!! message length changed while processing correlations.'
21448           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21449         endif ! msglen.eq.msglen1
21450       endif ! fg_rank.lt.nfgtasks-1
21451       if (ldone) goto 30
21452       ldone=.true.
21453       goto 10
21454    30 continue
21455 #endif
21456       if (lprn) then
21457         write (iout,'(a)') 'Contact function values:'
21458         do i=nnt_molec(2),nct_molec(2)-1
21459           write (iout,'(2i3,50(1x,i2,f5.2))') &
21460          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21461          j=1,num_cont_hb(i))
21462         enddo
21463       endif
21464       ecorr=0.0D0
21465       ecorr3=0.0d0
21466 !C Remove the loop below after debugging !!!
21467 !      do i=nnt_molec(2),nct_molec(2)
21468 !        do j=1,3
21469 !          gradcorr_nucl(j,i)=0.0D0
21470 !          gradxorr_nucl(j,i)=0.0D0
21471 !          gradcorr3_nucl(j,i)=0.0D0
21472 !          gradxorr3_nucl(j,i)=0.0D0
21473 !        enddo
21474 !      enddo
21475 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21476 !C Calculate the local-electrostatic correlation terms
21477       do i=iatsc_s_nucl,iatsc_e_nucl
21478         i1=i+1
21479         num_conti=num_cont_hb(i)
21480         num_conti1=num_cont_hb(i+1)
21481 !        print *,i,num_conti,num_conti1
21482         do jj=1,num_conti
21483           j=jcont_hb(jj,i)
21484           do kk=1,num_conti1
21485             j1=jcont_hb(kk,i1)
21486 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21487 !c     &         ' jj=',jj,' kk=',kk
21488             if (j1.eq.j+1 .or. j1.eq.j-1) then
21489 !C
21490 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21491 !C The system gains extra energy.
21492 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21493 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21494 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21495 !C
21496               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21497               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21498                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21499               n_corr=n_corr+1
21500             else if (j1.eq.j) then
21501 !C
21502 !C Contacts I-J and I-(J+1) occur simultaneously.
21503 !C The system loses extra energy.
21504 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21505 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21506 !C Need to implement full formulas 32 from Liwo et al., 1998.
21507 !C
21508 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21509 !c     &         ' jj=',jj,' kk=',kk
21510               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21511             endif
21512           enddo ! kk
21513           do kk=1,num_conti
21514             j1=jcont_hb(kk,i)
21515 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21516 !c     &         ' jj=',jj,' kk=',kk
21517             if (j1.eq.j+1) then
21518 !C Contacts I-J and (I+1)-J occur simultaneously.
21519 !C The system loses extra energy.
21520               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21521             endif ! j1==j+1
21522           enddo ! kk
21523         enddo ! jj
21524       enddo ! i
21525       return
21526       end subroutine multibody_hb_nucl
21527 !-----------------------------------------------------------
21528       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21529 !      implicit real*8 (a-h,o-z)
21530 !      include 'DIMENSIONS'
21531 !      include 'COMMON.IOUNITS'
21532 !      include 'COMMON.DERIV'
21533 !      include 'COMMON.INTERACT'
21534 !      include 'COMMON.CONTACTS'
21535       real(kind=8),dimension(3) :: gx,gx1
21536       logical :: lprn
21537 !el local variables
21538       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21539       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21540                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21541                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21542                    rlocshield
21543
21544       lprn=.false.
21545       eij=facont_hb(jj,i)
21546       ekl=facont_hb(kk,k)
21547       ees0pij=ees0p(jj,i)
21548       ees0pkl=ees0p(kk,k)
21549       ees0mij=ees0m(jj,i)
21550       ees0mkl=ees0m(kk,k)
21551       ekont=eij*ekl
21552       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21553 !      print *,"ehbcorr_nucl",ekont,ees
21554 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21555 !C Following 4 lines for diagnostics.
21556 !cd    ees0pkl=0.0D0
21557 !cd    ees0pij=1.0D0
21558 !cd    ees0mkl=0.0D0
21559 !cd    ees0mij=1.0D0
21560 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21561 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21562 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21563 !C Calculate the multi-body contribution to energy.
21564 !      ecorr_nucl=ecorr_nucl+ekont*ees
21565 !C Calculate multi-body contributions to the gradient.
21566       coeffpees0pij=coeffp*ees0pij
21567       coeffmees0mij=coeffm*ees0mij
21568       coeffpees0pkl=coeffp*ees0pkl
21569       coeffmees0mkl=coeffm*ees0mkl
21570       do ll=1,3
21571         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21572        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21573        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21574         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21575         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21576         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21577         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21578         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21579         coeffmees0mij*gacontm_hb1(ll,kk,k))
21580         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21581         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21582         coeffmees0mij*gacontm_hb2(ll,kk,k))
21583         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21584           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21585           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21586         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21587         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21588         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21589           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21590           coeffmees0mij*gacontm_hb3(ll,kk,k))
21591         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21592         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21593         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21594         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21595         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21596         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21597       enddo
21598       ehbcorr_nucl=ekont*ees
21599       return
21600       end function ehbcorr_nucl
21601 !-------------------------------------------------------------------------
21602
21603      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21604 !      implicit real*8 (a-h,o-z)
21605 !      include 'DIMENSIONS'
21606 !      include 'COMMON.IOUNITS'
21607 !      include 'COMMON.DERIV'
21608 !      include 'COMMON.INTERACT'
21609 !      include 'COMMON.CONTACTS'
21610       real(kind=8),dimension(3) :: gx,gx1
21611       logical :: lprn
21612 !el local variables
21613       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21614       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21615                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21616                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21617                    rlocshield
21618
21619       lprn=.false.
21620       eij=facont_hb(jj,i)
21621       ekl=facont_hb(kk,k)
21622       ees0pij=ees0p(jj,i)
21623       ees0pkl=ees0p(kk,k)
21624       ees0mij=ees0m(jj,i)
21625       ees0mkl=ees0m(kk,k)
21626       ekont=eij*ekl
21627       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21628 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21629 !C Following 4 lines for diagnostics.
21630 !cd    ees0pkl=0.0D0
21631 !cd    ees0pij=1.0D0
21632 !cd    ees0mkl=0.0D0
21633 !cd    ees0mij=1.0D0
21634 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21635 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21636 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21637 !C Calculate the multi-body contribution to energy.
21638 !      ecorr=ecorr+ekont*ees
21639 !C Calculate multi-body contributions to the gradient.
21640       coeffpees0pij=coeffp*ees0pij
21641       coeffmees0mij=coeffm*ees0mij
21642       coeffpees0pkl=coeffp*ees0pkl
21643       coeffmees0mkl=coeffm*ees0mkl
21644       do ll=1,3
21645         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21646        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21647        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21648         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21649         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21650         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21651         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21652         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21653         coeffmees0mij*gacontm_hb1(ll,kk,k))
21654         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21655         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21656         coeffmees0mij*gacontm_hb2(ll,kk,k))
21657         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21658           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21659           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21660         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21661         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21662         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21663           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21664           coeffmees0mij*gacontm_hb3(ll,kk,k))
21665         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21666         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21667         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21668         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21669         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21670         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21671       enddo
21672       ehbcorr3_nucl=ekont*ees
21673       return
21674       end function ehbcorr3_nucl
21675 #ifdef MPI
21676       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21677       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21678       real(kind=8):: buffer(dimen1,dimen2)
21679       num_kont=num_cont_hb(atom)
21680       do i=1,num_kont
21681         do k=1,8
21682           do j=1,3
21683             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21684           enddo ! j
21685         enddo ! k
21686         buffer(i,indx+25)=facont_hb(i,atom)
21687         buffer(i,indx+26)=ees0p(i,atom)
21688         buffer(i,indx+27)=ees0m(i,atom)
21689         buffer(i,indx+28)=d_cont(i,atom)
21690         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21691       enddo ! i
21692       buffer(1,indx+30)=dfloat(num_kont)
21693       return
21694       end subroutine pack_buffer
21695 !c------------------------------------------------------------------------------
21696       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21697       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21698       real(kind=8):: buffer(dimen1,dimen2)
21699 !      double precision zapas
21700 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21701 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21702 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21703 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21704       num_kont=buffer(1,indx+30)
21705       num_kont_old=num_cont_hb(atom)
21706       num_cont_hb(atom)=num_kont+num_kont_old
21707       do i=1,num_kont
21708         ii=i+num_kont_old
21709         do k=1,8
21710           do j=1,3
21711             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21712           enddo ! j
21713         enddo ! k
21714         facont_hb(ii,atom)=buffer(i,indx+25)
21715         ees0p(ii,atom)=buffer(i,indx+26)
21716         ees0m(ii,atom)=buffer(i,indx+27)
21717         d_cont(i,atom)=buffer(i,indx+28)
21718         jcont_hb(ii,atom)=buffer(i,indx+29)
21719       enddo ! i
21720       return
21721       end subroutine unpack_buffer
21722 !c------------------------------------------------------------------------------
21723 #endif
21724       subroutine ecatcat(ecationcation)
21725         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21726         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21727         r7,r4,ecationcation,k0,rcal
21728         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21729         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21730         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21731         gg,r
21732
21733         ecationcation=0.0d0
21734         if (nres_molec(5).eq.0) return
21735         rcat0=3.472
21736         epscalc=0.05
21737         r06 = rcat0**6
21738         r012 = r06**2
21739         k0 = 332.0*(2.0*2.0)/80.0
21740         itmp=0
21741
21742         do i=1,4
21743         itmp=itmp+nres_molec(i)
21744         enddo
21745 !        write(iout,*) "itmp",itmp
21746         do i=itmp+1,itmp+nres_molec(5)-1
21747
21748         xi=c(1,i)
21749         yi=c(2,i)
21750         zi=c(3,i)
21751
21752           xi=mod(xi,boxxsize)
21753           if (xi.lt.0) xi=xi+boxxsize
21754           yi=mod(yi,boxysize)
21755           if (yi.lt.0) yi=yi+boxysize
21756           zi=mod(zi,boxzsize)
21757           if (zi.lt.0) zi=zi+boxzsize
21758
21759           do j=i+1,itmp+nres_molec(5)
21760 !           print *,i,j,'catcat'
21761            xj=c(1,j)
21762            yj=c(2,j)
21763            zj=c(3,j)
21764           xj=dmod(xj,boxxsize)
21765           if (xj.lt.0) xj=xj+boxxsize
21766           yj=dmod(yj,boxysize)
21767           if (yj.lt.0) yj=yj+boxysize
21768           zj=dmod(zj,boxzsize)
21769           if (zj.lt.0) zj=zj+boxzsize
21770 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
21771       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21772       xj_safe=xj
21773       yj_safe=yj
21774       zj_safe=zj
21775       subchap=0
21776       do xshift=-1,1
21777       do yshift=-1,1
21778       do zshift=-1,1
21779           xj=xj_safe+xshift*boxxsize
21780           yj=yj_safe+yshift*boxysize
21781           zj=zj_safe+zshift*boxzsize
21782           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21783           if(dist_temp.lt.dist_init) then
21784             dist_init=dist_temp
21785             xj_temp=xj
21786             yj_temp=yj
21787             zj_temp=zj
21788             subchap=1
21789           endif
21790        enddo
21791        enddo
21792        enddo
21793        if (subchap.eq.1) then
21794           xj=xj_temp-xi
21795           yj=yj_temp-yi
21796           zj=zj_temp-zi
21797        else
21798           xj=xj_safe-xi
21799           yj=yj_safe-yi
21800           zj=zj_safe-zi
21801        endif
21802        rcal =xj**2+yj**2+zj**2
21803         ract=sqrt(rcal)
21804 !        rcat0=3.472
21805 !        epscalc=0.05
21806 !        r06 = rcat0**6
21807 !        r012 = r06**2
21808 !        k0 = 332*(2*2)/80
21809         Evan1cat=epscalc*(r012/rcal**6)
21810         Evan2cat=epscalc*2*(r06/rcal**3)
21811         Eeleccat=k0/ract
21812         r7 = rcal**7
21813         r4 = rcal**4
21814         r(1)=xj
21815         r(2)=yj
21816         r(3)=zj
21817         do k=1,3
21818           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21819           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21820           dEeleccat(k)=-k0*r(k)/ract**3
21821         enddo
21822         do k=1,3
21823           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21824           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
21825           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
21826         enddo
21827
21828 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
21829         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
21830        enddo
21831        enddo
21832        return
21833        end subroutine ecatcat
21834 !---------------------------------------------------------------------------
21835        subroutine ecat_prot(ecation_prot)
21836        integer i,j,k,subchap,itmp,inum
21837         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21838         r7,r4,ecationcation
21839         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21840         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
21841         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
21842         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
21843         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
21844         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
21845         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
21846         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
21847         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
21848         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
21849         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
21850         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21851         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
21852         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
21853         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
21854         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
21855         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
21856         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
21857         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
21858         dEvan1Cat
21859         real(kind=8),dimension(6) :: vcatprm
21860         ecation_prot=0.0d0
21861 ! first lets calculate interaction with peptide groups
21862         if (nres_molec(5).eq.0) return
21863          wconst=78
21864         wdip =1.092777950857032D2
21865         wdip=wdip/wconst
21866         wmodquad=-2.174122713004870D4
21867         wmodquad=wmodquad/wconst
21868         wquad1 = 3.901232068562804D1
21869         wquad1=wquad1/wconst
21870         wquad2 = 3
21871         wquad2=wquad2/wconst
21872         wvan1 = 0.1
21873         wvan2 = 6
21874         itmp=0
21875         do i=1,4
21876         itmp=itmp+nres_molec(i)
21877         enddo
21878 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
21879         do i=ibond_start,ibond_end
21880 !         cycle
21881          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
21882         xi=0.5d0*(c(1,i)+c(1,i+1))
21883         yi=0.5d0*(c(2,i)+c(2,i+1))
21884         zi=0.5d0*(c(3,i)+c(3,i+1))
21885           xi=mod(xi,boxxsize)
21886           if (xi.lt.0) xi=xi+boxxsize
21887           yi=mod(yi,boxysize)
21888           if (yi.lt.0) yi=yi+boxysize
21889           zi=mod(zi,boxzsize)
21890           if (zi.lt.0) zi=zi+boxzsize
21891
21892          do j=itmp+1,itmp+nres_molec(5)
21893            xj=c(1,j)
21894            yj=c(2,j)
21895            zj=c(3,j)
21896           xj=dmod(xj,boxxsize)
21897           if (xj.lt.0) xj=xj+boxxsize
21898           yj=dmod(yj,boxysize)
21899           if (yj.lt.0) yj=yj+boxysize
21900           zj=dmod(zj,boxzsize)
21901           if (zj.lt.0) zj=zj+boxzsize
21902       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21903       xj_safe=xj
21904       yj_safe=yj
21905       zj_safe=zj
21906       subchap=0
21907       do xshift=-1,1
21908       do yshift=-1,1
21909       do zshift=-1,1
21910           xj=xj_safe+xshift*boxxsize
21911           yj=yj_safe+yshift*boxysize
21912           zj=zj_safe+zshift*boxzsize
21913           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21914           if(dist_temp.lt.dist_init) then
21915             dist_init=dist_temp
21916             xj_temp=xj
21917             yj_temp=yj
21918             zj_temp=zj
21919             subchap=1
21920           endif
21921        enddo
21922        enddo
21923        enddo
21924        if (subchap.eq.1) then
21925           xj=xj_temp-xi
21926           yj=yj_temp-yi
21927           zj=zj_temp-zi
21928        else
21929           xj=xj_safe-xi
21930           yj=yj_safe-yi
21931           zj=zj_safe-zi
21932        endif
21933 !       enddo
21934 !       enddo
21935        rcpm = sqrt(xj**2+yj**2+zj**2)
21936        drcp_norm(1)=xj/rcpm
21937        drcp_norm(2)=yj/rcpm
21938        drcp_norm(3)=zj/rcpm
21939        dcmag=0.0
21940        do k=1,3
21941        dcmag=dcmag+dc(k,i)**2
21942        enddo
21943        dcmag=dsqrt(dcmag)
21944        do k=1,3
21945          myd_norm(k)=dc(k,i)/dcmag
21946        enddo
21947         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
21948         drcp_norm(3)*myd_norm(3)
21949         rsecp = rcpm**2
21950         Ir = 1.0d0/rcpm
21951         Irsecp = 1.0d0/rsecp
21952         Irthrp = Irsecp/rcpm
21953         Irfourp = Irthrp/rcpm
21954         Irfiftp = Irfourp/rcpm
21955         Irsistp=Irfiftp/rcpm
21956         Irseven=Irsistp/rcpm
21957         Irtwelv=Irsistp*Irsistp
21958         Irthir=Irtwelv/rcpm
21959         sin2thet = (1-costhet*costhet)
21960         sinthet=sqrt(sin2thet)
21961         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
21962              *sin2thet
21963         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
21964              2*wvan2**6*Irsistp)
21965         ecation_prot = ecation_prot+E1+E2
21966         dE1dr = -2*costhet*wdip*Irthrp-&
21967          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
21968         dE2dr = 3*wquad1*wquad2*Irfourp-     &
21969           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
21970         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
21971         do k=1,3
21972           drdpep(k) = -drcp_norm(k)
21973           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
21974           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
21975           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
21976           dEddci(k) = dEdcos*dcosddci(k)
21977         enddo
21978         do k=1,3
21979         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
21980         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
21981         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
21982         enddo
21983        enddo ! j
21984        enddo ! i
21985 !------------------------------------------sidechains
21986 !        do i=1,nres_molec(1)
21987         do i=ibond_start,ibond_end
21988          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
21989 !         cycle
21990 !        print *,i,ecation_prot
21991         xi=(c(1,i+nres))
21992         yi=(c(2,i+nres))
21993         zi=(c(3,i+nres))
21994           xi=mod(xi,boxxsize)
21995           if (xi.lt.0) xi=xi+boxxsize
21996           yi=mod(yi,boxysize)
21997           if (yi.lt.0) yi=yi+boxysize
21998           zi=mod(zi,boxzsize)
21999           if (zi.lt.0) zi=zi+boxzsize
22000           do k=1,3
22001             cm1(k)=dc(k,i+nres)
22002           enddo
22003            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22004          do j=itmp+1,itmp+nres_molec(5)
22005            xj=c(1,j)
22006            yj=c(2,j)
22007            zj=c(3,j)
22008           xj=dmod(xj,boxxsize)
22009           if (xj.lt.0) xj=xj+boxxsize
22010           yj=dmod(yj,boxysize)
22011           if (yj.lt.0) yj=yj+boxysize
22012           zj=dmod(zj,boxzsize)
22013           if (zj.lt.0) zj=zj+boxzsize
22014       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22015       xj_safe=xj
22016       yj_safe=yj
22017       zj_safe=zj
22018       subchap=0
22019       do xshift=-1,1
22020       do yshift=-1,1
22021       do zshift=-1,1
22022           xj=xj_safe+xshift*boxxsize
22023           yj=yj_safe+yshift*boxysize
22024           zj=zj_safe+zshift*boxzsize
22025           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22026           if(dist_temp.lt.dist_init) then
22027             dist_init=dist_temp
22028             xj_temp=xj
22029             yj_temp=yj
22030             zj_temp=zj
22031             subchap=1
22032           endif
22033        enddo
22034        enddo
22035        enddo
22036        if (subchap.eq.1) then
22037           xj=xj_temp-xi
22038           yj=yj_temp-yi
22039           zj=zj_temp-zi
22040        else
22041           xj=xj_safe-xi
22042           yj=yj_safe-yi
22043           zj=zj_safe-zi
22044        endif
22045 !       enddo
22046 !       enddo
22047          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22048             if(itype(i,1).eq.16) then
22049             inum=1
22050             else
22051             inum=2
22052             endif
22053             do k=1,6
22054             vcatprm(k)=catprm(k,inum)
22055             enddo
22056             dASGL=catprm(7,inum)
22057              do k=1,3
22058                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22059                 valpha(k)=c(k,i)
22060                 vcat(k)=c(k,j)
22061               enddo
22062                       do k=1,3
22063           dx(k) = vcat(k)-vcm(k)
22064         enddo
22065         do k=1,3
22066           v1(k)=(vcm(k)-valpha(k))
22067           v2(k)=(vcat(k)-valpha(k))
22068         enddo
22069         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22070         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22071         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22072
22073 !  The weights of the energy function calculated from
22074 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22075         wh2o=78
22076         wc = vcatprm(1)
22077         wc=wc/wh2o
22078         wdip =vcatprm(2)
22079         wdip=wdip/wh2o
22080         wquad1 =vcatprm(3)
22081         wquad1=wquad1/wh2o
22082         wquad2 = vcatprm(4)
22083         wquad2=wquad2/wh2o
22084         wquad2p = 1-wquad2
22085         wvan1 = vcatprm(5)
22086         wvan2 =vcatprm(6)
22087         opt = dx(1)**2+dx(2)**2
22088         rsecp = opt+dx(3)**2
22089         rs = sqrt(rsecp)
22090         rthrp = rsecp*rs
22091         rfourp = rthrp*rs
22092         rsixp = rfourp*rsecp
22093         reight=rsixp*rsecp
22094         Ir = 1.0d0/rs
22095         Irsecp = 1/rsecp
22096         Irthrp = Irsecp/rs
22097         Irfourp = Irthrp/rs
22098         Irsixp = 1/rsixp
22099         Ireight=1/reight
22100         Irtw=Irsixp*Irsixp
22101         Irthir=Irtw/rs
22102         Irfourt=Irthir/rs
22103         opt1 = (4*rs*dx(3)*wdip)
22104         opt2 = 6*rsecp*wquad1*opt
22105         opt3 = wquad1*wquad2p*Irsixp
22106         opt4 = (wvan1*wvan2**12)
22107         opt5 = opt4*12*Irfourt
22108         opt6 = 2*wvan1*wvan2**6
22109         opt7 = 6*opt6*Ireight
22110         opt8 = wdip/v1m
22111         opt10 = wdip/v2m
22112         opt11 = (rsecp*v2m)**2
22113         opt12 = (rsecp*v1m)**2
22114         opt14 = (v1m*v2m*rsecp)**2
22115         opt15 = -wquad1/v2m**2
22116         opt16 = (rthrp*(v1m*v2m)**2)**2
22117         opt17 = (v1m**2*rthrp)**2
22118         opt18 = -wquad1/rthrp
22119         opt19 = (v1m**2*v2m**2)**2
22120         Ec = wc*Ir
22121         do k=1,3
22122           dEcCat(k) = -(dx(k)*wc)*Irthrp
22123           dEcCm(k)=(dx(k)*wc)*Irthrp
22124           dEcCalp(k)=0.0d0
22125         enddo
22126         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22127         do k=1,3
22128           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22129                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22130           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22131                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22132           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22133                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22134                       *v1dpv2)/opt14
22135         enddo
22136         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22137         do k=1,3
22138           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22139                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22140                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22141           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22142                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22143                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22144           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22145                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22146                         v1dpv2**2)/opt19
22147         enddo
22148         Equad2=wquad1*wquad2p*Irthrp
22149         do k=1,3
22150           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22151           dEquad2Cm(k)=3*dx(k)*rs*opt3
22152           dEquad2Calp(k)=0.0d0
22153         enddo
22154         Evan1=opt4*Irtw
22155         do k=1,3
22156           dEvan1Cat(k)=-dx(k)*opt5
22157           dEvan1Cm(k)=dx(k)*opt5
22158           dEvan1Calp(k)=0.0d0
22159         enddo
22160         Evan2=-opt6*Irsixp
22161         do k=1,3
22162           dEvan2Cat(k)=dx(k)*opt7
22163           dEvan2Cm(k)=-dx(k)*opt7
22164           dEvan2Calp(k)=0.0d0
22165         enddo
22166         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22167 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22168
22169         do k=1,3
22170           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22171                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22172 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22173           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22174                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22175           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22176                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22177         enddo
22178             dscmag = 0.0d0
22179             do k=1,3
22180               dscvec(k) = dc(k,i+nres)
22181               dscmag = dscmag+dscvec(k)*dscvec(k)
22182             enddo
22183             dscmag3 = dscmag
22184             dscmag = sqrt(dscmag)
22185             dscmag3 = dscmag3*dscmag
22186             constA = 1.0d0+dASGL/dscmag
22187             constB = 0.0d0
22188             do k=1,3
22189               constB = constB+dscvec(k)*dEtotalCm(k)
22190             enddo
22191             constB = constB*dASGL/dscmag3
22192             do k=1,3
22193               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22194               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22195                constA*dEtotalCm(k)-constB*dscvec(k)
22196 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22197               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22198               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22199              enddo
22200         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22201            if(itype(i,1).eq.14) then
22202             inum=3
22203             else
22204             inum=4
22205             endif
22206             do k=1,6
22207             vcatprm(k)=catprm(k,inum)
22208             enddo
22209             dASGL=catprm(7,inum)
22210              do k=1,3
22211                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22212                 valpha(k)=c(k,i)
22213                 vcat(k)=c(k,j)
22214               enddo
22215
22216         do k=1,3
22217           dx(k) = vcat(k)-vcm(k)
22218         enddo
22219         do k=1,3
22220           v1(k)=(vcm(k)-valpha(k))
22221           v2(k)=(vcat(k)-valpha(k))
22222         enddo
22223         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22224         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22225         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22226 !  The weights of the energy function calculated from
22227 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22228         wh2o=78
22229         wdip =vcatprm(2)
22230         wdip=wdip/wh2o
22231         wquad1 =vcatprm(3)
22232         wquad1=wquad1/wh2o
22233         wquad2 = vcatprm(4)
22234         wquad2=wquad2/wh2o
22235         wquad2p = 1-wquad2
22236         wvan1 = vcatprm(5)
22237         wvan2 =vcatprm(6)
22238         opt = dx(1)**2+dx(2)**2
22239         rsecp = opt+dx(3)**2
22240         rs = sqrt(rsecp)
22241         rthrp = rsecp*rs
22242         rfourp = rthrp*rs
22243         rsixp = rfourp*rsecp
22244         reight=rsixp*rsecp
22245         Ir = 1.0d0/rs
22246         Irsecp = 1/rsecp
22247         Irthrp = Irsecp/rs
22248         Irfourp = Irthrp/rs
22249         Irsixp = 1/rsixp
22250         Ireight=1/reight
22251         Irtw=Irsixp*Irsixp
22252         Irthir=Irtw/rs
22253         Irfourt=Irthir/rs
22254         opt1 = (4*rs*dx(3)*wdip)
22255         opt2 = 6*rsecp*wquad1*opt
22256         opt3 = wquad1*wquad2p*Irsixp
22257         opt4 = (wvan1*wvan2**12)
22258         opt5 = opt4*12*Irfourt
22259         opt6 = 2*wvan1*wvan2**6
22260         opt7 = 6*opt6*Ireight
22261         opt8 = wdip/v1m
22262         opt10 = wdip/v2m
22263         opt11 = (rsecp*v2m)**2
22264         opt12 = (rsecp*v1m)**2
22265         opt14 = (v1m*v2m*rsecp)**2
22266         opt15 = -wquad1/v2m**2
22267         opt16 = (rthrp*(v1m*v2m)**2)**2
22268         opt17 = (v1m**2*rthrp)**2
22269         opt18 = -wquad1/rthrp
22270         opt19 = (v1m**2*v2m**2)**2
22271         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22272         do k=1,3
22273           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22274                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22275          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22276                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22277           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22278                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22279                       *v1dpv2)/opt14
22280         enddo
22281         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22282         do k=1,3
22283           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22284                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22285                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22286           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22287                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22288                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22289           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22290                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22291                         v1dpv2**2)/opt19
22292         enddo
22293         Equad2=wquad1*wquad2p*Irthrp
22294         do k=1,3
22295           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22296           dEquad2Cm(k)=3*dx(k)*rs*opt3
22297           dEquad2Calp(k)=0.0d0
22298         enddo
22299         Evan1=opt4*Irtw
22300         do k=1,3
22301           dEvan1Cat(k)=-dx(k)*opt5
22302           dEvan1Cm(k)=dx(k)*opt5
22303           dEvan1Calp(k)=0.0d0
22304         enddo
22305         Evan2=-opt6*Irsixp
22306         do k=1,3
22307           dEvan2Cat(k)=dx(k)*opt7
22308           dEvan2Cm(k)=-dx(k)*opt7
22309           dEvan2Calp(k)=0.0d0
22310         enddo
22311          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22312         do k=1,3
22313           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22314                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22315           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22316                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22317           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22318                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22319         enddo
22320             dscmag = 0.0d0
22321             do k=1,3
22322               dscvec(k) = c(k,i+nres)-c(k,i)
22323               dscmag = dscmag+dscvec(k)*dscvec(k)
22324             enddo
22325             dscmag3 = dscmag
22326             dscmag = sqrt(dscmag)
22327             dscmag3 = dscmag3*dscmag
22328             constA = 1+dASGL/dscmag
22329             constB = 0.0d0
22330             do k=1,3
22331               constB = constB+dscvec(k)*dEtotalCm(k)
22332             enddo
22333             constB = constB*dASGL/dscmag3
22334             do k=1,3
22335               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22336               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22337                constA*dEtotalCm(k)-constB*dscvec(k)
22338               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22339               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22340              enddo
22341            else
22342             rcal = 0.0d0
22343             do k=1,3
22344               r(k) = c(k,j)-c(k,i+nres)
22345               rcal = rcal+r(k)*r(k)
22346             enddo
22347             ract=sqrt(rcal)
22348             rocal=1.5
22349             epscalc=0.2
22350             r0p=0.5*(rocal+sig0(itype(i,1)))
22351             r06 = r0p**6
22352             r012 = r06*r06
22353             Evan1=epscalc*(r012/rcal**6)
22354             Evan2=epscalc*2*(r06/rcal**3)
22355             r4 = rcal**4
22356             r7 = rcal**7
22357             do k=1,3
22358               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22359               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22360             enddo
22361             do k=1,3
22362               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22363             enddo
22364                  ecation_prot = ecation_prot+ Evan1+Evan2
22365             do  k=1,3
22366                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22367                dEtotalCm(k)
22368               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22369               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22370              enddo
22371          endif ! 13-16 residues
22372        enddo !j
22373        enddo !i
22374        return
22375        end subroutine ecat_prot
22376
22377 !----------------------------------------------------------------------------
22378 !-----------------------------------------------------------------------------
22379 !-----------------------------------------------------------------------------
22380       subroutine eprot_sc_base(escbase)
22381       use calc_data
22382 !      implicit real*8 (a-h,o-z)
22383 !      include 'DIMENSIONS'
22384 !      include 'COMMON.GEO'
22385 !      include 'COMMON.VAR'
22386 !      include 'COMMON.LOCAL'
22387 !      include 'COMMON.CHAIN'
22388 !      include 'COMMON.DERIV'
22389 !      include 'COMMON.NAMES'
22390 !      include 'COMMON.INTERACT'
22391 !      include 'COMMON.IOUNITS'
22392 !      include 'COMMON.CALC'
22393 !      include 'COMMON.CONTROL'
22394 !      include 'COMMON.SBRIDGE'
22395       logical :: lprn
22396 !el local variables
22397       integer :: iint,itypi,itypi1,itypj,subchap
22398       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22399       real(kind=8) :: evdw,sig0ij
22400       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22401                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22402                     sslipi,sslipj,faclip
22403       integer :: ii
22404       real(kind=8) :: fracinbuf
22405        real (kind=8) :: escbase
22406        real (kind=8),dimension(4):: ener
22407        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22408        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22409         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22410         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22411         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22412         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22413         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22414         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22415        real(kind=8),dimension(3,2)::chead,erhead_tail
22416        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22417        integer troll
22418        eps_out=80.0d0
22419        escbase=0.0d0
22420 !       do i=1,nres_molec(1)
22421         do i=ibond_start,ibond_end
22422         if (itype(i,1).eq.ntyp1_molec(1)) cycle
22423         itypi  = itype(i,1)
22424         dxi    = dc_norm(1,nres+i)
22425         dyi    = dc_norm(2,nres+i)
22426         dzi    = dc_norm(3,nres+i)
22427         dsci_inv = vbld_inv(i+nres)
22428         xi=c(1,nres+i)
22429         yi=c(2,nres+i)
22430         zi=c(3,nres+i)
22431         xi=mod(xi,boxxsize)
22432          if (xi.lt.0) xi=xi+boxxsize
22433         yi=mod(yi,boxysize)
22434          if (yi.lt.0) yi=yi+boxysize
22435         zi=mod(zi,boxzsize)
22436          if (zi.lt.0) zi=zi+boxzsize
22437          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22438            itypj= itype(j,2)
22439            if (itype(j,2).eq.ntyp1_molec(2))cycle
22440            xj=c(1,j+nres)
22441            yj=c(2,j+nres)
22442            zj=c(3,j+nres)
22443            xj=dmod(xj,boxxsize)
22444            if (xj.lt.0) xj=xj+boxxsize
22445            yj=dmod(yj,boxysize)
22446            if (yj.lt.0) yj=yj+boxysize
22447            zj=dmod(zj,boxzsize)
22448            if (zj.lt.0) zj=zj+boxzsize
22449           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22450           xj_safe=xj
22451           yj_safe=yj
22452           zj_safe=zj
22453           subchap=0
22454
22455           do xshift=-1,1
22456           do yshift=-1,1
22457           do zshift=-1,1
22458           xj=xj_safe+xshift*boxxsize
22459           yj=yj_safe+yshift*boxysize
22460           zj=zj_safe+zshift*boxzsize
22461           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22462           if(dist_temp.lt.dist_init) then
22463             dist_init=dist_temp
22464             xj_temp=xj
22465             yj_temp=yj
22466             zj_temp=zj
22467             subchap=1
22468           endif
22469           enddo
22470           enddo
22471           enddo
22472           if (subchap.eq.1) then
22473           xj=xj_temp-xi
22474           yj=yj_temp-yi
22475           zj=zj_temp-zi
22476           else
22477           xj=xj_safe-xi
22478           yj=yj_safe-yi
22479           zj=zj_safe-zi
22480           endif
22481           dxj = dc_norm( 1, nres+j )
22482           dyj = dc_norm( 2, nres+j )
22483           dzj = dc_norm( 3, nres+j )
22484 !          print *,i,j,itypi,itypj
22485           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
22486           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
22487 !          d1i=0.0d0
22488 !          d1j=0.0d0
22489 !          BetaT = 1.0d0 / (298.0d0 * Rb)
22490 ! Gay-berne var's
22491           sig0ij = sigma_scbase( itypi,itypj )
22492           chi1   = chi_scbase( itypi, itypj,1 )
22493           chi2   = chi_scbase( itypi, itypj,2 )
22494 !          chi1=0.0d0
22495 !          chi2=0.0d0
22496           chi12  = chi1 * chi2
22497           chip1  = chipp_scbase( itypi, itypj,1 )
22498           chip2  = chipp_scbase( itypi, itypj,2 )
22499 !          chip1=0.0d0
22500 !          chip2=0.0d0
22501           chip12 = chip1 * chip2
22502 ! not used by momo potential, but needed by sc_angular which is shared
22503 ! by all energy_potential subroutines
22504           alf1   = 0.0d0
22505           alf2   = 0.0d0
22506           alf12  = 0.0d0
22507           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
22508 !       a12sq = a12sq * a12sq
22509 ! charge of amino acid itypi is...
22510           chis1 = chis_scbase(itypi,itypj,1)
22511           chis2 = chis_scbase(itypi,itypj,2)
22512           chis12 = chis1 * chis2
22513           sig1 = sigmap1_scbase(itypi,itypj)
22514           sig2 = sigmap2_scbase(itypi,itypj)
22515 !       write (*,*) "sig1 = ", sig1
22516 !       write (*,*) "sig2 = ", sig2
22517 ! alpha factors from Fcav/Gcav
22518           b1 = alphasur_scbase(1,itypi,itypj)
22519 !          b1=0.0d0
22520           b2 = alphasur_scbase(2,itypi,itypj)
22521           b3 = alphasur_scbase(3,itypi,itypj)
22522           b4 = alphasur_scbase(4,itypi,itypj)
22523 ! used to determine whether we want to do quadrupole calculations
22524 ! used by Fgb
22525        eps_in = epsintab_scbase(itypi,itypj)
22526        if (eps_in.eq.0.0) eps_in=1.0
22527        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22528 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
22529 !-------------------------------------------------------------------
22530 ! tail location and distance calculations
22531        DO k = 1,3
22532 ! location of polar head is computed by taking hydrophobic centre
22533 ! and moving by a d1 * dc_norm vector
22534 ! see unres publications for very informative images
22535         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
22536         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
22537 ! distance
22538 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22539 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22540         Rhead_distance(k) = chead(k,2) - chead(k,1)
22541        END DO
22542 ! pitagoras (root of sum of squares)
22543        Rhead = dsqrt( &
22544           (Rhead_distance(1)*Rhead_distance(1)) &
22545         + (Rhead_distance(2)*Rhead_distance(2)) &
22546         + (Rhead_distance(3)*Rhead_distance(3)))
22547 !-------------------------------------------------------------------
22548 ! zero everything that should be zero'ed
22549        evdwij = 0.0d0
22550        ECL = 0.0d0
22551        Elj = 0.0d0
22552        Equad = 0.0d0
22553        Epol = 0.0d0
22554        Fcav=0.0d0
22555        eheadtail = 0.0d0
22556        dGCLdOM1 = 0.0d0
22557        dGCLdOM2 = 0.0d0
22558        dGCLdOM12 = 0.0d0
22559        dPOLdOM1 = 0.0d0
22560        dPOLdOM2 = 0.0d0
22561           Fcav = 0.0d0
22562           dFdR = 0.0d0
22563           dCAVdOM1  = 0.0d0
22564           dCAVdOM2  = 0.0d0
22565           dCAVdOM12 = 0.0d0
22566           dscj_inv = vbld_inv(j+nres)
22567 !          print *,i,j,dscj_inv,dsci_inv
22568 ! rij holds 1/(distance of Calpha atoms)
22569           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22570           rij  = dsqrt(rrij)
22571 !----------------------------
22572           CALL sc_angular
22573 ! this should be in elgrad_init but om's are calculated by sc_angular
22574 ! which in turn is used by older potentials
22575 ! om = omega, sqom = om^2
22576           sqom1  = om1 * om1
22577           sqom2  = om2 * om2
22578           sqom12 = om12 * om12
22579
22580 ! now we calculate EGB - Gey-Berne
22581 ! It will be summed up in evdwij and saved in evdw
22582           sigsq     = 1.0D0  / sigsq
22583           sig       = sig0ij * dsqrt(sigsq)
22584 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22585           rij_shift = 1.0/rij - sig + sig0ij
22586           IF (rij_shift.le.0.0D0) THEN
22587            evdw = 1.0D20
22588            RETURN
22589           END IF
22590           sigder = -sig * sigsq
22591           rij_shift = 1.0D0 / rij_shift
22592           fac       = rij_shift**expon
22593           c1        = fac  * fac * aa_scbase(itypi,itypj)
22594 !          c1        = 0.0d0
22595           c2        = fac  * bb_scbase(itypi,itypj)
22596 !          c2        = 0.0d0
22597           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22598           eps2der   = eps3rt * evdwij
22599           eps3der   = eps2rt * evdwij
22600 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22601           evdwij    = eps2rt * eps3rt * evdwij
22602           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22603           fac    = -expon * (c1 + evdwij) * rij_shift
22604           sigder = fac * sigder
22605 !          fac    = rij * fac
22606 ! Calculate distance derivative
22607           gg(1) =  fac
22608           gg(2) =  fac
22609           gg(3) =  fac
22610 !          if (b2.gt.0.0) then
22611           fac = chis1 * sqom1 + chis2 * sqom2 &
22612           - 2.0d0 * chis12 * om1 * om2 * om12
22613 ! we will use pom later in Gcav, so dont mess with it!
22614           pom = 1.0d0 - chis1 * chis2 * sqom12
22615           Lambf = (1.0d0 - (fac / pom))
22616           Lambf = dsqrt(Lambf)
22617           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22618 !       write (*,*) "sparrow = ", sparrow
22619           Chif = 1.0d0/rij * sparrow
22620           ChiLambf = Chif * Lambf
22621           eagle = dsqrt(ChiLambf)
22622           bat = ChiLambf ** 11.0d0
22623           top = b1 * ( eagle + b2 * ChiLambf - b3 )
22624           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
22625           botsq = bot * bot
22626           Fcav = top / bot
22627 !          print *,i,j,Fcav
22628           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
22629           dbot = 12.0d0 * b4 * bat * Lambf
22630           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22631 !       dFdR = 0.0d0
22632 !      write (*,*) "dFcav/dR = ", dFdR
22633           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
22634           dbot = 12.0d0 * b4 * bat * Chif
22635           eagle = Lambf * pom
22636           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22637           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22638           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22639               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22640
22641           dFdL = ((dtop * bot - top * dbot) / botsq)
22642 !       dFdL = 0.0d0
22643           dCAVdOM1  = dFdL * ( dFdOM1 )
22644           dCAVdOM2  = dFdL * ( dFdOM2 )
22645           dCAVdOM12 = dFdL * ( dFdOM12 )
22646
22647           ertail(1) = xj*rij
22648           ertail(2) = yj*rij
22649           ertail(3) = zj*rij
22650 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
22651 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
22652 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
22653 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
22654 !           print *,"EOMY",eom1,eom2,eom12
22655 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22656 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
22657 ! here dtail=0.0
22658 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
22659 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22660        DO k = 1, 3
22661 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22662 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22663         pom = ertail(k)
22664 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22665         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22666                   - (( dFdR + gg(k) ) * pom)
22667 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22668 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22669 !     &             - ( dFdR * pom )
22670         pom = ertail(k)
22671 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22672         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22673                   + (( dFdR + gg(k) ) * pom)
22674 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22675 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22676 !c!     &             + ( dFdR * pom )
22677
22678         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22679                   - (( dFdR + gg(k) ) * ertail(k))
22680 !c!     &             - ( dFdR * ertail(k))
22681
22682         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22683                   + (( dFdR + gg(k) ) * ertail(k))
22684 !c!     &             + ( dFdR * ertail(k))
22685
22686         gg(k) = 0.0d0
22687 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22688 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22689       END DO
22690
22691 !          else
22692
22693 !          endif
22694 !Now dipole-dipole
22695          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
22696        w1 = wdipdip_scbase(1,itypi,itypj)
22697        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
22698        w3 = wdipdip_scbase(2,itypi,itypj)
22699 !c!-------------------------------------------------------------------
22700 !c! ECL
22701        fac = (om12 - 3.0d0 * om1 * om2)
22702        c1 = (w1 / (Rhead**3.0d0)) * fac
22703        c2 = (w2 / Rhead ** 6.0d0)  &
22704          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22705        c3= (w3/ Rhead ** 6.0d0)  &
22706          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22707        ECL = c1 - c2 + c3
22708 !c!       write (*,*) "w1 = ", w1
22709 !c!       write (*,*) "w2 = ", w2
22710 !c!       write (*,*) "om1 = ", om1
22711 !c!       write (*,*) "om2 = ", om2
22712 !c!       write (*,*) "om12 = ", om12
22713 !c!       write (*,*) "fac = ", fac
22714 !c!       write (*,*) "c1 = ", c1
22715 !c!       write (*,*) "c2 = ", c2
22716 !c!       write (*,*) "Ecl = ", Ecl
22717 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
22718 !c!       write (*,*) "c2_2 = ",
22719 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22720 !c!-------------------------------------------------------------------
22721 !c! dervative of ECL is GCL...
22722 !c! dECL/dr
22723        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
22724        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
22725          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
22726        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
22727          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22728        dGCLdR = c1 - c2 + c3
22729 !c! dECL/dom1
22730        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
22731        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22732          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
22733        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
22734        dGCLdOM1 = c1 - c2 + c3
22735 !c! dECL/dom2
22736        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
22737        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22738          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
22739        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
22740        dGCLdOM2 = c1 - c2 + c3
22741 !c! dECL/dom12
22742        c1 = w1 / (Rhead ** 3.0d0)
22743        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
22744        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
22745        dGCLdOM12 = c1 - c2 + c3
22746        DO k= 1, 3
22747         erhead(k) = Rhead_distance(k)/Rhead
22748        END DO
22749        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22750        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22751        facd1 = d1i * vbld_inv(i+nres)
22752        facd2 = d1j * vbld_inv(j+nres)
22753        DO k = 1, 3
22754
22755         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22756         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22757                   - dGCLdR * pom
22758         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22759         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22760                   + dGCLdR * pom
22761
22762         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22763                   - dGCLdR * erhead(k)
22764         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22765                   + dGCLdR * erhead(k)
22766        END DO
22767        endif
22768 !now charge with dipole eg. ARG-dG
22769        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
22770       alphapol1 = alphapol_scbase(itypi,itypj)
22771        w1        = wqdip_scbase(1,itypi,itypj)
22772        w2        = wqdip_scbase(2,itypi,itypj)
22773 !       w1=0.0d0
22774 !       w2=0.0d0
22775 !       pis       = sig0head_scbase(itypi,itypj)
22776 !       eps_head   = epshead_scbase(itypi,itypj)
22777 !c!-------------------------------------------------------------------
22778 !c! R1 - distance between head of ith side chain and tail of jth sidechain
22779        R1 = 0.0d0
22780        DO k = 1, 3
22781 !c! Calculate head-to-tail distances tail is center of side-chain
22782         R1=R1+(c(k,j+nres)-chead(k,1))**2
22783        END DO
22784 !c! Pitagoras
22785        R1 = dsqrt(R1)
22786
22787 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
22788 !c!     &        +dhead(1,1,itypi,itypj))**2))
22789 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
22790 !c!     &        +dhead(2,1,itypi,itypj))**2))
22791
22792 !c!-------------------------------------------------------------------
22793 !c! ecl
22794        sparrow  = w1  *  om1
22795        hawk     = w2 *  (1.0d0 - sqom2)
22796        Ecl = sparrow / Rhead**2.0d0 &
22797            - hawk    / Rhead**4.0d0
22798 !c!-------------------------------------------------------------------
22799 !c! derivative of ecl is Gcl
22800 !c! dF/dr part
22801        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
22802                 + 4.0d0 * hawk    / Rhead**5.0d0
22803 !c! dF/dom1
22804        dGCLdOM1 = (w1) / (Rhead**2.0d0)
22805 !c! dF/dom2
22806        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
22807 !c--------------------------------------------------------------------
22808 !c Polarization energy
22809 !c Epol
22810        MomoFac1 = (1.0d0 - chi1 * sqom2)
22811        RR1  = R1 * R1 / MomoFac1
22812        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
22813        fgb1 = sqrt( RR1 + a12sq * ee1)
22814 !       eps_inout_fac=0.0d0
22815        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
22816 ! derivative of Epol is Gpol...
22817        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
22818                 / (fgb1 ** 5.0d0)
22819        dFGBdR1 = ( (R1 / MomoFac1) &
22820              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
22821              / ( 2.0d0 * fgb1 )
22822        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
22823                * (2.0d0 - 0.5d0 * ee1) ) &
22824                / (2.0d0 * fgb1)
22825        dPOLdR1 = dPOLdFGB1 * dFGBdR1
22826 !       dPOLdR1 = 0.0d0
22827        dPOLdOM1 = 0.0d0
22828        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
22829        DO k = 1, 3
22830         erhead(k) = Rhead_distance(k)/Rhead
22831         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
22832        END DO
22833
22834        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22835        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22836        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
22837 !       bat=0.0d0
22838        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
22839        facd1 = d1i * vbld_inv(i+nres)
22840        facd2 = d1j * vbld_inv(j+nres)
22841 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22842
22843        DO k = 1, 3
22844         hawk = (erhead_tail(k,1) + &
22845         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
22846 !        facd1=0.0d0
22847 !        facd2=0.0d0
22848         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22849         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
22850                    - dGCLdR * pom &
22851                    - dPOLdR1 *  (erhead_tail(k,1))
22852 !     &             - dGLJdR * pom
22853
22854         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22855         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
22856                    + dGCLdR * pom  &
22857                    + dPOLdR1 * (erhead_tail(k,1))
22858 !     &             + dGLJdR * pom
22859
22860
22861         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
22862                   - dGCLdR * erhead(k) &
22863                   - dPOLdR1 * erhead_tail(k,1)
22864 !     &             - dGLJdR * erhead(k)
22865
22866         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
22867                   + dGCLdR * erhead(k)  &
22868                   + dPOLdR1 * erhead_tail(k,1)
22869 !     &             + dGLJdR * erhead(k)
22870
22871        END DO
22872        endif
22873 !       print *,i,j,evdwij,epol,Fcav,ECL
22874        escbase=escbase+evdwij+epol+Fcav+ECL
22875        call sc_grad_scbase
22876          enddo
22877       enddo
22878
22879       return
22880       end subroutine eprot_sc_base
22881       SUBROUTINE sc_grad_scbase
22882       use calc_data
22883
22884        real (kind=8) :: dcosom1(3),dcosom2(3)
22885        eom1  =    &
22886               eps2der * eps2rt_om1   &
22887             - 2.0D0 * alf1 * eps3der &
22888             + sigder * sigsq_om1     &
22889             + dCAVdOM1               &
22890             + dGCLdOM1               &
22891             + dPOLdOM1
22892
22893        eom2  =  &
22894               eps2der * eps2rt_om2   &
22895             + 2.0D0 * alf2 * eps3der &
22896             + sigder * sigsq_om2     &
22897             + dCAVdOM2               &
22898             + dGCLdOM2               &
22899             + dPOLdOM2
22900
22901        eom12 =    &
22902               evdwij  * eps1_om12     &
22903             + eps2der * eps2rt_om12   &
22904             - 2.0D0 * alf12 * eps3der &
22905             + sigder *sigsq_om12      &
22906             + dCAVdOM12               &
22907             + dGCLdOM12
22908
22909 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
22910 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
22911 !               gg(1),gg(2),"rozne"
22912        DO k = 1, 3
22913         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
22914         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
22915         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
22916         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
22917                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22918                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22919         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
22920                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22921                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22922         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
22923         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
22924        END DO
22925        RETURN
22926       END SUBROUTINE sc_grad_scbase
22927
22928
22929       subroutine epep_sc_base(epepbase)
22930       use calc_data
22931       logical :: lprn
22932 !el local variables
22933       integer :: iint,itypi,itypi1,itypj,subchap
22934       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22935       real(kind=8) :: evdw,sig0ij
22936       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22937                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22938                     sslipi,sslipj,faclip
22939       integer :: ii
22940       real(kind=8) :: fracinbuf
22941        real (kind=8) :: epepbase
22942        real (kind=8),dimension(4):: ener
22943        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22944        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22945         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22946         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22947         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22948         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22949         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22950         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22951        real(kind=8),dimension(3,2)::chead,erhead_tail
22952        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22953        integer troll
22954        eps_out=80.0d0
22955        epepbase=0.0d0
22956 !       do i=1,nres_molec(1)-1
22957         do i=ibond_start,ibond_end
22958         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
22959 !C        itypi  = itype(i,1)
22960         dxi    = dc_norm(1,i)
22961         dyi    = dc_norm(2,i)
22962         dzi    = dc_norm(3,i)
22963 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
22964         dsci_inv = vbld_inv(i+1)/2.0
22965         xi=(c(1,i)+c(1,i+1))/2.0
22966         yi=(c(2,i)+c(2,i+1))/2.0
22967         zi=(c(3,i)+c(3,i+1))/2.0
22968         xi=mod(xi,boxxsize)
22969          if (xi.lt.0) xi=xi+boxxsize
22970         yi=mod(yi,boxysize)
22971          if (yi.lt.0) yi=yi+boxysize
22972         zi=mod(zi,boxzsize)
22973          if (zi.lt.0) zi=zi+boxzsize
22974          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22975            itypj= itype(j,2)
22976            if (itype(j,2).eq.ntyp1_molec(2))cycle
22977            xj=c(1,j+nres)
22978            yj=c(2,j+nres)
22979            zj=c(3,j+nres)
22980            xj=dmod(xj,boxxsize)
22981            if (xj.lt.0) xj=xj+boxxsize
22982            yj=dmod(yj,boxysize)
22983            if (yj.lt.0) yj=yj+boxysize
22984            zj=dmod(zj,boxzsize)
22985            if (zj.lt.0) zj=zj+boxzsize
22986           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22987           xj_safe=xj
22988           yj_safe=yj
22989           zj_safe=zj
22990           subchap=0
22991
22992           do xshift=-1,1
22993           do yshift=-1,1
22994           do zshift=-1,1
22995           xj=xj_safe+xshift*boxxsize
22996           yj=yj_safe+yshift*boxysize
22997           zj=zj_safe+zshift*boxzsize
22998           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22999           if(dist_temp.lt.dist_init) then
23000             dist_init=dist_temp
23001             xj_temp=xj
23002             yj_temp=yj
23003             zj_temp=zj
23004             subchap=1
23005           endif
23006           enddo
23007           enddo
23008           enddo
23009           if (subchap.eq.1) then
23010           xj=xj_temp-xi
23011           yj=yj_temp-yi
23012           zj=zj_temp-zi
23013           else
23014           xj=xj_safe-xi
23015           yj=yj_safe-yi
23016           zj=zj_safe-zi
23017           endif
23018           dxj = dc_norm( 1, nres+j )
23019           dyj = dc_norm( 2, nres+j )
23020           dzj = dc_norm( 3, nres+j )
23021 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23022 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23023
23024 ! Gay-berne var's
23025           sig0ij = sigma_pepbase(itypj )
23026           chi1   = chi_pepbase(itypj,1 )
23027           chi2   = chi_pepbase(itypj,2 )
23028 !          chi1=0.0d0
23029 !          chi2=0.0d0
23030           chi12  = chi1 * chi2
23031           chip1  = chipp_pepbase(itypj,1 )
23032           chip2  = chipp_pepbase(itypj,2 )
23033 !          chip1=0.0d0
23034 !          chip2=0.0d0
23035           chip12 = chip1 * chip2
23036           chis1 = chis_pepbase(itypj,1)
23037           chis2 = chis_pepbase(itypj,2)
23038           chis12 = chis1 * chis2
23039           sig1 = sigmap1_pepbase(itypj)
23040           sig2 = sigmap2_pepbase(itypj)
23041 !       write (*,*) "sig1 = ", sig1
23042 !       write (*,*) "sig2 = ", sig2
23043        DO k = 1,3
23044 ! location of polar head is computed by taking hydrophobic centre
23045 ! and moving by a d1 * dc_norm vector
23046 ! see unres publications for very informative images
23047         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23048 ! + d1i * dc_norm(k, i+nres)
23049         chead(k,2) = c(k, j+nres)
23050 ! + d1j * dc_norm(k, j+nres)
23051 ! distance
23052 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23053 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23054         Rhead_distance(k) = chead(k,2) - chead(k,1)
23055 !        print *,gvdwc_pepbase(k,i)
23056
23057        END DO
23058        Rhead = dsqrt( &
23059           (Rhead_distance(1)*Rhead_distance(1)) &
23060         + (Rhead_distance(2)*Rhead_distance(2)) &
23061         + (Rhead_distance(3)*Rhead_distance(3)))
23062
23063 ! alpha factors from Fcav/Gcav
23064           b1 = alphasur_pepbase(1,itypj)
23065 !          b1=0.0d0
23066           b2 = alphasur_pepbase(2,itypj)
23067           b3 = alphasur_pepbase(3,itypj)
23068           b4 = alphasur_pepbase(4,itypj)
23069           alf1   = 0.0d0
23070           alf2   = 0.0d0
23071           alf12  = 0.0d0
23072           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23073 !          print *,i,j,rrij
23074           rij  = dsqrt(rrij)
23075 !----------------------------
23076        evdwij = 0.0d0
23077        ECL = 0.0d0
23078        Elj = 0.0d0
23079        Equad = 0.0d0
23080        Epol = 0.0d0
23081        Fcav=0.0d0
23082        eheadtail = 0.0d0
23083        dGCLdOM1 = 0.0d0
23084        dGCLdOM2 = 0.0d0
23085        dGCLdOM12 = 0.0d0
23086        dPOLdOM1 = 0.0d0
23087        dPOLdOM2 = 0.0d0
23088           Fcav = 0.0d0
23089           dFdR = 0.0d0
23090           dCAVdOM1  = 0.0d0
23091           dCAVdOM2  = 0.0d0
23092           dCAVdOM12 = 0.0d0
23093           dscj_inv = vbld_inv(j+nres)
23094           CALL sc_angular
23095 ! this should be in elgrad_init but om's are calculated by sc_angular
23096 ! which in turn is used by older potentials
23097 ! om = omega, sqom = om^2
23098           sqom1  = om1 * om1
23099           sqom2  = om2 * om2
23100           sqom12 = om12 * om12
23101
23102 ! now we calculate EGB - Gey-Berne
23103 ! It will be summed up in evdwij and saved in evdw
23104           sigsq     = 1.0D0  / sigsq
23105           sig       = sig0ij * dsqrt(sigsq)
23106           rij_shift = 1.0/rij - sig + sig0ij
23107           IF (rij_shift.le.0.0D0) THEN
23108            evdw = 1.0D20
23109            RETURN
23110           END IF
23111           sigder = -sig * sigsq
23112           rij_shift = 1.0D0 / rij_shift
23113           fac       = rij_shift**expon
23114           c1        = fac  * fac * aa_pepbase(itypj)
23115 !          c1        = 0.0d0
23116           c2        = fac  * bb_pepbase(itypj)
23117 !          c2        = 0.0d0
23118           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23119           eps2der   = eps3rt * evdwij
23120           eps3der   = eps2rt * evdwij
23121 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23122           evdwij    = eps2rt * eps3rt * evdwij
23123           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23124           fac    = -expon * (c1 + evdwij) * rij_shift
23125           sigder = fac * sigder
23126 !          fac    = rij * fac
23127 ! Calculate distance derivative
23128           gg(1) =  fac
23129           gg(2) =  fac
23130           gg(3) =  fac
23131           fac = chis1 * sqom1 + chis2 * sqom2 &
23132           - 2.0d0 * chis12 * om1 * om2 * om12
23133 ! we will use pom later in Gcav, so dont mess with it!
23134           pom = 1.0d0 - chis1 * chis2 * sqom12
23135           Lambf = (1.0d0 - (fac / pom))
23136           Lambf = dsqrt(Lambf)
23137           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23138 !       write (*,*) "sparrow = ", sparrow
23139           Chif = 1.0d0/rij * sparrow
23140           ChiLambf = Chif * Lambf
23141           eagle = dsqrt(ChiLambf)
23142           bat = ChiLambf ** 11.0d0
23143           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23144           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23145           botsq = bot * bot
23146           Fcav = top / bot
23147 !          print *,i,j,Fcav
23148           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23149           dbot = 12.0d0 * b4 * bat * Lambf
23150           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23151 !       dFdR = 0.0d0
23152 !      write (*,*) "dFcav/dR = ", dFdR
23153           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23154           dbot = 12.0d0 * b4 * bat * Chif
23155           eagle = Lambf * pom
23156           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23157           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23158           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23159               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23160
23161           dFdL = ((dtop * bot - top * dbot) / botsq)
23162 !       dFdL = 0.0d0
23163           dCAVdOM1  = dFdL * ( dFdOM1 )
23164           dCAVdOM2  = dFdL * ( dFdOM2 )
23165           dCAVdOM12 = dFdL * ( dFdOM12 )
23166
23167           ertail(1) = xj*rij
23168           ertail(2) = yj*rij
23169           ertail(3) = zj*rij
23170        DO k = 1, 3
23171 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23172 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23173         pom = ertail(k)
23174 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23175         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23176                   - (( dFdR + gg(k) ) * pom)/2.0
23177 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
23178 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23179 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23180 !     &             - ( dFdR * pom )
23181         pom = ertail(k)
23182 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23183         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23184                   + (( dFdR + gg(k) ) * pom)
23185 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23186 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23187 !c!     &             + ( dFdR * pom )
23188
23189         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23190                   - (( dFdR + gg(k) ) * ertail(k))/2.0
23191 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
23192
23193 !c!     &             - ( dFdR * ertail(k))
23194
23195         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23196                   + (( dFdR + gg(k) ) * ertail(k))
23197 !c!     &             + ( dFdR * ertail(k))
23198
23199         gg(k) = 0.0d0
23200 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23201 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23202       END DO
23203
23204
23205        w1 = wdipdip_pepbase(1,itypj)
23206        w2 = -wdipdip_pepbase(3,itypj)/2.0
23207        w3 = wdipdip_pepbase(2,itypj)
23208 !       w1=0.0d0
23209 !       w2=0.0d0
23210 !c!-------------------------------------------------------------------
23211 !c! ECL
23212 !       w3=0.0d0
23213        fac = (om12 - 3.0d0 * om1 * om2)
23214        c1 = (w1 / (Rhead**3.0d0)) * fac
23215        c2 = (w2 / Rhead ** 6.0d0)  &
23216          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23217        c3= (w3/ Rhead ** 6.0d0)  &
23218          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23219
23220        ECL = c1 - c2 + c3
23221
23222        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23223        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23224          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23225        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23226          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23227
23228        dGCLdR = c1 - c2 + c3
23229 !c! dECL/dom1
23230        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23231        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23232          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23233        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23234        dGCLdOM1 = c1 - c2 + c3
23235 !c! dECL/dom2
23236        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23237        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23238          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23239        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23240
23241        dGCLdOM2 = c1 - c2 + c3
23242 !c! dECL/dom12
23243        c1 = w1 / (Rhead ** 3.0d0)
23244        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23245        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23246        dGCLdOM12 = c1 - c2 + c3
23247        DO k= 1, 3
23248         erhead(k) = Rhead_distance(k)/Rhead
23249        END DO
23250        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23251        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23252 !       facd1 = d1 * vbld_inv(i+nres)
23253 !       facd2 = d2 * vbld_inv(j+nres)
23254        DO k = 1, 3
23255
23256 !        pom = erhead(k)
23257 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23258 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
23259 !                  - dGCLdR * pom
23260         pom = erhead(k)
23261 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23262         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23263                   + dGCLdR * pom
23264
23265         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23266                   - dGCLdR * erhead(k)/2.0d0
23267 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23268         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23269                   - dGCLdR * erhead(k)/2.0d0
23270 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23271         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23272                   + dGCLdR * erhead(k)
23273        END DO
23274 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
23275        epepbase=epepbase+evdwij+Fcav+ECL
23276        call sc_grad_pepbase
23277        enddo
23278        enddo
23279       END SUBROUTINE epep_sc_base
23280       SUBROUTINE sc_grad_pepbase
23281       use calc_data
23282
23283        real (kind=8) :: dcosom1(3),dcosom2(3)
23284        eom1  =    &
23285               eps2der * eps2rt_om1   &
23286             - 2.0D0 * alf1 * eps3der &
23287             + sigder * sigsq_om1     &
23288             + dCAVdOM1               &
23289             + dGCLdOM1               &
23290             + dPOLdOM1
23291
23292        eom2  =  &
23293               eps2der * eps2rt_om2   &
23294             + 2.0D0 * alf2 * eps3der &
23295             + sigder * sigsq_om2     &
23296             + dCAVdOM2               &
23297             + dGCLdOM2               &
23298             + dPOLdOM2
23299
23300        eom12 =    &
23301               evdwij  * eps1_om12     &
23302             + eps2der * eps2rt_om12   &
23303             - 2.0D0 * alf12 * eps3der &
23304             + sigder *sigsq_om12      &
23305             + dCAVdOM12               &
23306             + dGCLdOM12
23307 !        om12=0.0
23308 !        eom12=0.0
23309 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23310 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
23311 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23312 !                 *dsci_inv*2.0
23313 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23314 !               gg(1),gg(2),"rozne"
23315        DO k = 1, 3
23316         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
23317         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23318         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23319         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
23320                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23321                  *dsci_inv*2.0 &
23322                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23323         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
23324                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
23325                  *dsci_inv*2.0 &
23326                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23327 !         print *,eom12,eom2,om12,om2
23328 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23329 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23330         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
23331                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23332                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23333         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
23334        END DO
23335        RETURN
23336       END SUBROUTINE sc_grad_pepbase
23337       subroutine eprot_sc_phosphate(escpho)
23338       use calc_data
23339 !      implicit real*8 (a-h,o-z)
23340 !      include 'DIMENSIONS'
23341 !      include 'COMMON.GEO'
23342 !      include 'COMMON.VAR'
23343 !      include 'COMMON.LOCAL'
23344 !      include 'COMMON.CHAIN'
23345 !      include 'COMMON.DERIV'
23346 !      include 'COMMON.NAMES'
23347 !      include 'COMMON.INTERACT'
23348 !      include 'COMMON.IOUNITS'
23349 !      include 'COMMON.CALC'
23350 !      include 'COMMON.CONTROL'
23351 !      include 'COMMON.SBRIDGE'
23352       logical :: lprn
23353 !el local variables
23354       integer :: iint,itypi,itypi1,itypj,subchap
23355       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23356       real(kind=8) :: evdw,sig0ij
23357       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23358                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23359                     sslipi,sslipj,faclip,alpha_sco
23360       integer :: ii
23361       real(kind=8) :: fracinbuf
23362        real (kind=8) :: escpho
23363        real (kind=8),dimension(4):: ener
23364        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23365        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23366         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23367         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23368         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23369         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23370         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23371         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23372        real(kind=8),dimension(3,2)::chead,erhead_tail
23373        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23374        integer troll
23375        eps_out=80.0d0
23376        escpho=0.0d0
23377 !       do i=1,nres_molec(1)
23378         do i=ibond_start,ibond_end
23379         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23380         itypi  = itype(i,1)
23381         dxi    = dc_norm(1,nres+i)
23382         dyi    = dc_norm(2,nres+i)
23383         dzi    = dc_norm(3,nres+i)
23384         dsci_inv = vbld_inv(i+nres)
23385         xi=c(1,nres+i)
23386         yi=c(2,nres+i)
23387         zi=c(3,nres+i)
23388         xi=mod(xi,boxxsize)
23389          if (xi.lt.0) xi=xi+boxxsize
23390         yi=mod(yi,boxysize)
23391          if (yi.lt.0) yi=yi+boxysize
23392         zi=mod(zi,boxzsize)
23393          if (zi.lt.0) zi=zi+boxzsize
23394          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23395            itypj= itype(j,2)
23396            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23397             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23398            xj=(c(1,j)+c(1,j+1))/2.0
23399            yj=(c(2,j)+c(2,j+1))/2.0
23400            zj=(c(3,j)+c(3,j+1))/2.0
23401            xj=dmod(xj,boxxsize)
23402            if (xj.lt.0) xj=xj+boxxsize
23403            yj=dmod(yj,boxysize)
23404            if (yj.lt.0) yj=yj+boxysize
23405            zj=dmod(zj,boxzsize)
23406            if (zj.lt.0) zj=zj+boxzsize
23407           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23408           xj_safe=xj
23409           yj_safe=yj
23410           zj_safe=zj
23411           subchap=0
23412           do xshift=-1,1
23413           do yshift=-1,1
23414           do zshift=-1,1
23415           xj=xj_safe+xshift*boxxsize
23416           yj=yj_safe+yshift*boxysize
23417           zj=zj_safe+zshift*boxzsize
23418           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23419           if(dist_temp.lt.dist_init) then
23420             dist_init=dist_temp
23421             xj_temp=xj
23422             yj_temp=yj
23423             zj_temp=zj
23424             subchap=1
23425           endif
23426           enddo
23427           enddo
23428           enddo
23429           if (subchap.eq.1) then
23430           xj=xj_temp-xi
23431           yj=yj_temp-yi
23432           zj=zj_temp-zi
23433           else
23434           xj=xj_safe-xi
23435           yj=yj_safe-yi
23436           zj=zj_safe-zi
23437           endif
23438           dxj = dc_norm( 1,j )
23439           dyj = dc_norm( 2,j )
23440           dzj = dc_norm( 3,j )
23441           dscj_inv = vbld_inv(j+1)
23442
23443 ! Gay-berne var's
23444           sig0ij = sigma_scpho(itypi )
23445           chi1   = chi_scpho(itypi,1 )
23446           chi2   = chi_scpho(itypi,2 )
23447 !          chi1=0.0d0
23448 !          chi2=0.0d0
23449           chi12  = chi1 * chi2
23450           chip1  = chipp_scpho(itypi,1 )
23451           chip2  = chipp_scpho(itypi,2 )
23452 !          chip1=0.0d0
23453 !          chip2=0.0d0
23454           chip12 = chip1 * chip2
23455           chis1 = chis_scpho(itypi,1)
23456           chis2 = chis_scpho(itypi,2)
23457           chis12 = chis1 * chis2
23458           sig1 = sigmap1_scpho(itypi)
23459           sig2 = sigmap2_scpho(itypi)
23460 !       write (*,*) "sig1 = ", sig1
23461 !       write (*,*) "sig1 = ", sig1
23462 !       write (*,*) "sig2 = ", sig2
23463 ! alpha factors from Fcav/Gcav
23464           alf1   = 0.0d0
23465           alf2   = 0.0d0
23466           alf12  = 0.0d0
23467           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
23468
23469           b1 = alphasur_scpho(1,itypi)
23470 !          b1=0.0d0
23471           b2 = alphasur_scpho(2,itypi)
23472           b3 = alphasur_scpho(3,itypi)
23473           b4 = alphasur_scpho(4,itypi)
23474 ! used to determine whether we want to do quadrupole calculations
23475 ! used by Fgb
23476        eps_in = epsintab_scpho(itypi)
23477        if (eps_in.eq.0.0) eps_in=1.0
23478        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23479 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23480 !-------------------------------------------------------------------
23481 ! tail location and distance calculations
23482           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
23483           d1j = 0.0
23484        DO k = 1,3
23485 ! location of polar head is computed by taking hydrophobic centre
23486 ! and moving by a d1 * dc_norm vector
23487 ! see unres publications for very informative images
23488         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23489         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
23490 ! distance
23491 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23492 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23493         Rhead_distance(k) = chead(k,2) - chead(k,1)
23494        END DO
23495 ! pitagoras (root of sum of squares)
23496        Rhead = dsqrt( &
23497           (Rhead_distance(1)*Rhead_distance(1)) &
23498         + (Rhead_distance(2)*Rhead_distance(2)) &
23499         + (Rhead_distance(3)*Rhead_distance(3)))
23500        Rhead_sq=Rhead**2.0
23501 !-------------------------------------------------------------------
23502 ! zero everything that should be zero'ed
23503        evdwij = 0.0d0
23504        ECL = 0.0d0
23505        Elj = 0.0d0
23506        Equad = 0.0d0
23507        Epol = 0.0d0
23508        Fcav=0.0d0
23509        eheadtail = 0.0d0
23510        dGCLdR=0.0d0
23511        dGCLdOM1 = 0.0d0
23512        dGCLdOM2 = 0.0d0
23513        dGCLdOM12 = 0.0d0
23514        dPOLdOM1 = 0.0d0
23515        dPOLdOM2 = 0.0d0
23516           Fcav = 0.0d0
23517           dFdR = 0.0d0
23518           dCAVdOM1  = 0.0d0
23519           dCAVdOM2  = 0.0d0
23520           dCAVdOM12 = 0.0d0
23521           dscj_inv = vbld_inv(j+1)/2.0
23522 !dhead_scbasej(itypi,itypj)
23523 !          print *,i,j,dscj_inv,dsci_inv
23524 ! rij holds 1/(distance of Calpha atoms)
23525           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23526           rij  = dsqrt(rrij)
23527 !----------------------------
23528           CALL sc_angular
23529 ! this should be in elgrad_init but om's are calculated by sc_angular
23530 ! which in turn is used by older potentials
23531 ! om = omega, sqom = om^2
23532           sqom1  = om1 * om1
23533           sqom2  = om2 * om2
23534           sqom12 = om12 * om12
23535
23536 ! now we calculate EGB - Gey-Berne
23537 ! It will be summed up in evdwij and saved in evdw
23538           sigsq     = 1.0D0  / sigsq
23539           sig       = sig0ij * dsqrt(sigsq)
23540 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23541           rij_shift = 1.0/rij - sig + sig0ij
23542           IF (rij_shift.le.0.0D0) THEN
23543            evdw = 1.0D20
23544            RETURN
23545           END IF
23546           sigder = -sig * sigsq
23547           rij_shift = 1.0D0 / rij_shift
23548           fac       = rij_shift**expon
23549           c1        = fac  * fac * aa_scpho(itypi)
23550 !          c1        = 0.0d0
23551           c2        = fac  * bb_scpho(itypi)
23552 !          c2        = 0.0d0
23553           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23554           eps2der   = eps3rt * evdwij
23555           eps3der   = eps2rt * evdwij
23556 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23557           evdwij    = eps2rt * eps3rt * evdwij
23558           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23559           fac    = -expon * (c1 + evdwij) * rij_shift
23560           sigder = fac * sigder
23561 !          fac    = rij * fac
23562 ! Calculate distance derivative
23563           gg(1) =  fac
23564           gg(2) =  fac
23565           gg(3) =  fac
23566           fac = chis1 * sqom1 + chis2 * sqom2 &
23567           - 2.0d0 * chis12 * om1 * om2 * om12
23568 ! we will use pom later in Gcav, so dont mess with it!
23569           pom = 1.0d0 - chis1 * chis2 * sqom12
23570           Lambf = (1.0d0 - (fac / pom))
23571           Lambf = dsqrt(Lambf)
23572           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23573 !       write (*,*) "sparrow = ", sparrow
23574           Chif = 1.0d0/rij * sparrow
23575           ChiLambf = Chif * Lambf
23576           eagle = dsqrt(ChiLambf)
23577           bat = ChiLambf ** 11.0d0
23578           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23579           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23580           botsq = bot * bot
23581           Fcav = top / bot
23582           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23583           dbot = 12.0d0 * b4 * bat * Lambf
23584           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23585 !       dFdR = 0.0d0
23586 !      write (*,*) "dFcav/dR = ", dFdR
23587           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23588           dbot = 12.0d0 * b4 * bat * Chif
23589           eagle = Lambf * pom
23590           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23591           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23592           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23593               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23594
23595           dFdL = ((dtop * bot - top * dbot) / botsq)
23596 !       dFdL = 0.0d0
23597           dCAVdOM1  = dFdL * ( dFdOM1 )
23598           dCAVdOM2  = dFdL * ( dFdOM2 )
23599           dCAVdOM12 = dFdL * ( dFdOM12 )
23600
23601           ertail(1) = xj*rij
23602           ertail(2) = yj*rij
23603           ertail(3) = zj*rij
23604        DO k = 1, 3
23605 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23606 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23607 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
23608
23609         pom = ertail(k)
23610 !        print *,pom,gg(k),dFdR
23611 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23612         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
23613                   - (( dFdR + gg(k) ) * pom)
23614 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23615 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23616 !     &             - ( dFdR * pom )
23617 !        pom = ertail(k)
23618 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23619 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
23620 !                  + (( dFdR + gg(k) ) * pom)
23621 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23622 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23623 !c!     &             + ( dFdR * pom )
23624
23625         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
23626                   - (( dFdR + gg(k) ) * ertail(k))
23627 !c!     &             - ( dFdR * ertail(k))
23628
23629         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
23630                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23631
23632         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
23633                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23634
23635 !c!     &             + ( dFdR * ertail(k))
23636
23637         gg(k) = 0.0d0
23638         ENDDO
23639 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23640 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23641 !      alphapol1 = alphapol_scpho(itypi)
23642        if (wqq_scpho(itypi).ne.0.0) then
23643        Qij=wqq_scpho(itypi)/eps_in
23644        alpha_sco=1.d0/alphi_scpho(itypi)
23645 !       Qij=0.0
23646        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
23647 !c! derivative of Ecl is Gcl...
23648        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
23649                 (Rhead*alpha_sco+1) ) / Rhead_sq
23650        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
23651        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
23652        w1        = wqdip_scpho(1,itypi)
23653        w2        = wqdip_scpho(2,itypi)
23654 !       w1=0.0d0
23655 !       w2=0.0d0
23656 !       pis       = sig0head_scbase(itypi,itypj)
23657 !       eps_head   = epshead_scbase(itypi,itypj)
23658 !c!-------------------------------------------------------------------
23659
23660 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23661 !c!     &        +dhead(1,1,itypi,itypj))**2))
23662 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23663 !c!     &        +dhead(2,1,itypi,itypj))**2))
23664
23665 !c!-------------------------------------------------------------------
23666 !c! ecl
23667        sparrow  = w1  *  om1
23668        hawk     = w2 *  (1.0d0 - sqom2)
23669        Ecl = sparrow / Rhead**2.0d0 &
23670            - hawk    / Rhead**4.0d0
23671 !c!-------------------------------------------------------------------
23672        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
23673            1.0/rij,sparrow
23674
23675 !c! derivative of ecl is Gcl
23676 !c! dF/dr part
23677        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23678                 + 4.0d0 * hawk    / Rhead**5.0d0
23679 !c! dF/dom1
23680        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23681 !c! dF/dom2
23682        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23683        endif
23684
23685 !c--------------------------------------------------------------------
23686 !c Polarization energy
23687 !c Epol
23688        R1 = 0.0d0
23689        DO k = 1, 3
23690 !c! Calculate head-to-tail distances tail is center of side-chain
23691         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
23692        END DO
23693 !c! Pitagoras
23694        R1 = dsqrt(R1)
23695
23696       alphapol1 = alphapol_scpho(itypi)
23697 !      alphapol1=0.0
23698        MomoFac1 = (1.0d0 - chi2 * sqom1)
23699        RR1  = R1 * R1 / MomoFac1
23700        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23701 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
23702        fgb1 = sqrt( RR1 + a12sq * ee1)
23703 !       eps_inout_fac=0.0d0
23704        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23705 ! derivative of Epol is Gpol...
23706        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23707                 / (fgb1 ** 5.0d0)
23708        dFGBdR1 = ( (R1 / MomoFac1) &
23709              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23710              / ( 2.0d0 * fgb1 )
23711        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23712                * (2.0d0 - 0.5d0 * ee1) ) &
23713                / (2.0d0 * fgb1)
23714        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23715 !       dPOLdR1 = 0.0d0
23716 !       dPOLdOM1 = 0.0d0
23717        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
23718                * (2.0d0 - 0.5d0 * ee1) ) &
23719                / (2.0d0 * fgb1)
23720
23721        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
23722        dPOLdOM2 = 0.0
23723        DO k = 1, 3
23724         erhead(k) = Rhead_distance(k)/Rhead
23725         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
23726        END DO
23727
23728        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23729        erdxj = scalar( erhead(1), dC_norm(1,j) )
23730        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23731 !       bat=0.0d0
23732        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
23733        facd1 = d1i * vbld_inv(i+nres)
23734        facd2 = d1j * vbld_inv(j)
23735 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23736
23737        DO k = 1, 3
23738         hawk = (erhead_tail(k,1) + &
23739         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23740 !        facd1=0.0d0
23741 !        facd2=0.0d0
23742 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
23743 !                pom,(erhead_tail(k,1))
23744
23745 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
23746         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23747         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
23748                    - dGCLdR * pom &
23749                    - dPOLdR1 *  (erhead_tail(k,1))
23750 !     &             - dGLJdR * pom
23751
23752         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
23753 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
23754 !                   + dGCLdR * pom  &
23755 !                   + dPOLdR1 * (erhead_tail(k,1))
23756 !     &             + dGLJdR * pom
23757
23758
23759         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
23760                   - dGCLdR * erhead(k) &
23761                   - dPOLdR1 * erhead_tail(k,1)
23762 !     &             - dGLJdR * erhead(k)
23763
23764         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
23765                   + (dGCLdR * erhead(k)  &
23766                   + dPOLdR1 * erhead_tail(k,1))/2.0
23767         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
23768                   + (dGCLdR * erhead(k)  &
23769                   + dPOLdR1 * erhead_tail(k,1))/2.0
23770
23771 !     &             + dGLJdR * erhead(k)
23772 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
23773
23774        END DO
23775 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
23776        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
23777         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
23778        escpho=escpho+evdwij+epol+Fcav+ECL
23779        call sc_grad_scpho
23780          enddo
23781
23782       enddo
23783
23784       return
23785       end subroutine eprot_sc_phosphate
23786       SUBROUTINE sc_grad_scpho
23787       use calc_data
23788
23789        real (kind=8) :: dcosom1(3),dcosom2(3)
23790        eom1  =    &
23791               eps2der * eps2rt_om1   &
23792             - 2.0D0 * alf1 * eps3der &
23793             + sigder * sigsq_om1     &
23794             + dCAVdOM1               &
23795             + dGCLdOM1               &
23796             + dPOLdOM1
23797
23798        eom2  =  &
23799               eps2der * eps2rt_om2   &
23800             + 2.0D0 * alf2 * eps3der &
23801             + sigder * sigsq_om2     &
23802             + dCAVdOM2               &
23803             + dGCLdOM2               &
23804             + dPOLdOM2
23805
23806        eom12 =    &
23807               evdwij  * eps1_om12     &
23808             + eps2der * eps2rt_om12   &
23809             - 2.0D0 * alf12 * eps3der &
23810             + sigder *sigsq_om12      &
23811             + dCAVdOM12               &
23812             + dGCLdOM12
23813 !        om12=0.0
23814 !        eom12=0.0
23815 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23816 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
23817 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23818 !                 *dsci_inv*2.0
23819 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23820 !               gg(1),gg(2),"rozne"
23821        DO k = 1, 3
23822         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23823         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
23824         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23825         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
23826                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
23827                  *dscj_inv*2.0 &
23828                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23829         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
23830                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
23831                  *dscj_inv*2.0 &
23832                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23833         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
23834                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
23835                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23836
23837 !         print *,eom12,eom2,om12,om2
23838 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23839 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23840 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
23841 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23842 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23843         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
23844        END DO
23845        RETURN
23846       END SUBROUTINE sc_grad_scpho
23847       subroutine eprot_pep_phosphate(epeppho)
23848       use calc_data
23849 !      implicit real*8 (a-h,o-z)
23850 !      include 'DIMENSIONS'
23851 !      include 'COMMON.GEO'
23852 !      include 'COMMON.VAR'
23853 !      include 'COMMON.LOCAL'
23854 !      include 'COMMON.CHAIN'
23855 !      include 'COMMON.DERIV'
23856 !      include 'COMMON.NAMES'
23857 !      include 'COMMON.INTERACT'
23858 !      include 'COMMON.IOUNITS'
23859 !      include 'COMMON.CALC'
23860 !      include 'COMMON.CONTROL'
23861 !      include 'COMMON.SBRIDGE'
23862       logical :: lprn
23863 !el local variables
23864       integer :: iint,itypi,itypi1,itypj,subchap
23865       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23866       real(kind=8) :: evdw,sig0ij
23867       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23868                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23869                     sslipi,sslipj,faclip
23870       integer :: ii
23871       real(kind=8) :: fracinbuf
23872        real (kind=8) :: epeppho
23873        real (kind=8),dimension(4):: ener
23874        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23875        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23876         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23877         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23878         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23879         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23880         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23881         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23882        real(kind=8),dimension(3,2)::chead,erhead_tail
23883        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23884        integer troll
23885        real (kind=8) :: dcosom1(3),dcosom2(3)
23886        epeppho=0.0d0
23887 !       do i=1,nres_molec(1)
23888         do i=ibond_start,ibond_end
23889         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23890         itypi  = itype(i,1)
23891         dsci_inv = vbld_inv(i+1)/2.0
23892         dxi    = dc_norm(1,i)
23893         dyi    = dc_norm(2,i)
23894         dzi    = dc_norm(3,i)
23895         xi=(c(1,i)+c(1,i+1))/2.0
23896         yi=(c(2,i)+c(2,i+1))/2.0
23897         zi=(c(3,i)+c(3,i+1))/2.0
23898         xi=mod(xi,boxxsize)
23899          if (xi.lt.0) xi=xi+boxxsize
23900         yi=mod(yi,boxysize)
23901          if (yi.lt.0) yi=yi+boxysize
23902         zi=mod(zi,boxzsize)
23903          if (zi.lt.0) zi=zi+boxzsize
23904          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23905            itypj= itype(j,2)
23906            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23907             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23908            xj=(c(1,j)+c(1,j+1))/2.0
23909            yj=(c(2,j)+c(2,j+1))/2.0
23910            zj=(c(3,j)+c(3,j+1))/2.0
23911            xj=dmod(xj,boxxsize)
23912            if (xj.lt.0) xj=xj+boxxsize
23913            yj=dmod(yj,boxysize)
23914            if (yj.lt.0) yj=yj+boxysize
23915            zj=dmod(zj,boxzsize)
23916            if (zj.lt.0) zj=zj+boxzsize
23917           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23918           xj_safe=xj
23919           yj_safe=yj
23920           zj_safe=zj
23921           subchap=0
23922           do xshift=-1,1
23923           do yshift=-1,1
23924           do zshift=-1,1
23925           xj=xj_safe+xshift*boxxsize
23926           yj=yj_safe+yshift*boxysize
23927           zj=zj_safe+zshift*boxzsize
23928           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23929           if(dist_temp.lt.dist_init) then
23930             dist_init=dist_temp
23931             xj_temp=xj
23932             yj_temp=yj
23933             zj_temp=zj
23934             subchap=1
23935           endif
23936           enddo
23937           enddo
23938           enddo
23939           if (subchap.eq.1) then
23940           xj=xj_temp-xi
23941           yj=yj_temp-yi
23942           zj=zj_temp-zi
23943           else
23944           xj=xj_safe-xi
23945           yj=yj_safe-yi
23946           zj=zj_safe-zi
23947           endif
23948           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23949           rij  = dsqrt(rrij)
23950           dxj = dc_norm( 1,j )
23951           dyj = dc_norm( 2,j )
23952           dzj = dc_norm( 3,j )
23953           dscj_inv = vbld_inv(j+1)/2.0
23954 ! Gay-berne var's
23955           sig0ij = sigma_peppho
23956 !          chi1=0.0d0
23957 !          chi2=0.0d0
23958           chi12  = chi1 * chi2
23959 !          chip1=0.0d0
23960 !          chip2=0.0d0
23961           chip12 = chip1 * chip2
23962 !          chis1 = 0.0d0
23963 !          chis2 = 0.0d0
23964           chis12 = chis1 * chis2
23965           sig1 = sigmap1_peppho
23966           sig2 = sigmap2_peppho
23967 !       write (*,*) "sig1 = ", sig1
23968 !       write (*,*) "sig1 = ", sig1
23969 !       write (*,*) "sig2 = ", sig2
23970 ! alpha factors from Fcav/Gcav
23971           alf1   = 0.0d0
23972           alf2   = 0.0d0
23973           alf12  = 0.0d0
23974           b1 = alphasur_peppho(1)
23975 !          b1=0.0d0
23976           b2 = alphasur_peppho(2)
23977           b3 = alphasur_peppho(3)
23978           b4 = alphasur_peppho(4)
23979           CALL sc_angular
23980        sqom1=om1*om1
23981        evdwij = 0.0d0
23982        ECL = 0.0d0
23983        Elj = 0.0d0
23984        Equad = 0.0d0
23985        Epol = 0.0d0
23986        Fcav=0.0d0
23987        eheadtail = 0.0d0
23988        dGCLdR=0.0d0
23989        dGCLdOM1 = 0.0d0
23990        dGCLdOM2 = 0.0d0
23991        dGCLdOM12 = 0.0d0
23992        dPOLdOM1 = 0.0d0
23993        dPOLdOM2 = 0.0d0
23994           Fcav = 0.0d0
23995           dFdR = 0.0d0
23996           dCAVdOM1  = 0.0d0
23997           dCAVdOM2  = 0.0d0
23998           dCAVdOM12 = 0.0d0
23999           rij_shift = rij
24000           fac       = rij_shift**expon
24001           c1        = fac  * fac * aa_peppho
24002 !          c1        = 0.0d0
24003           c2        = fac  * bb_peppho
24004 !          c2        = 0.0d0
24005           evdwij    =  c1 + c2
24006 ! Now cavity....................
24007        eagle = dsqrt(1.0/rij_shift)
24008        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24009           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24010           botsq = bot * bot
24011           Fcav = top / bot
24012           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24013           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24014           dFdR = ((dtop * bot - top * dbot) / botsq)
24015        w1        = wqdip_peppho(1)
24016        w2        = wqdip_peppho(2)
24017 !       w1=0.0d0
24018 !       w2=0.0d0
24019 !       pis       = sig0head_scbase(itypi,itypj)
24020 !       eps_head   = epshead_scbase(itypi,itypj)
24021 !c!-------------------------------------------------------------------
24022
24023 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24024 !c!     &        +dhead(1,1,itypi,itypj))**2))
24025 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24026 !c!     &        +dhead(2,1,itypi,itypj))**2))
24027
24028 !c!-------------------------------------------------------------------
24029 !c! ecl
24030        sparrow  = w1  *  om1
24031        hawk     = w2 *  (1.0d0 - sqom1)
24032        Ecl = sparrow * rij_shift**2.0d0 &
24033            - hawk    * rij_shift**4.0d0
24034 !c!-------------------------------------------------------------------
24035 !c! derivative of ecl is Gcl
24036 !c! dF/dr part
24037 !       rij_shift=5.0
24038        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24039                 + 4.0d0 * hawk    * rij_shift**5.0d0
24040 !c! dF/dom1
24041        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24042 !c! dF/dom2
24043        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24044        eom1  =    dGCLdOM1+dGCLdOM2
24045        eom2  =    0.0
24046
24047           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24048 !          fac=0.0
24049           gg(1) =  fac*xj*rij
24050           gg(2) =  fac*yj*rij
24051           gg(3) =  fac*zj*rij
24052          do k=1,3
24053          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24054          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24055          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24056          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24057          gg(k)=0.0
24058          enddo
24059
24060       DO k = 1, 3
24061         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24062         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24063         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24064         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24065 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24066         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24067 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24068         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24069                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24070         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24071                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24072         enddo
24073        epeppho=epeppho+evdwij+Fcav+ECL
24074 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24075        enddo
24076        enddo
24077       end subroutine eprot_pep_phosphate
24078 !!!!!!!!!!!!!!!!-------------------------------------------------------------
24079       subroutine emomo(evdw)
24080       use calc_data
24081       use comm_momo
24082 !      implicit real*8 (a-h,o-z)
24083 !      include 'DIMENSIONS'
24084 !      include 'COMMON.GEO'
24085 !      include 'COMMON.VAR'
24086 !      include 'COMMON.LOCAL'
24087 !      include 'COMMON.CHAIN'
24088 !      include 'COMMON.DERIV'
24089 !      include 'COMMON.NAMES'
24090 !      include 'COMMON.INTERACT'
24091 !      include 'COMMON.IOUNITS'
24092 !      include 'COMMON.CALC'
24093 !      include 'COMMON.CONTROL'
24094 !      include 'COMMON.SBRIDGE'
24095       logical :: lprn
24096 !el local variables
24097       integer :: iint,itypi1,subchap,isel
24098       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
24099       real(kind=8) :: evdw
24100       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24101                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24102                     sslipi,sslipj,faclip,alpha_sco
24103       integer :: ii
24104       real(kind=8) :: fracinbuf
24105        real (kind=8) :: escpho
24106        real (kind=8),dimension(4):: ener
24107        real(kind=8) :: b1,b2,egb
24108        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
24109         Lambf,&
24110         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
24111         dFdOM2,dFdL,dFdOM12,&
24112         federmaus,&
24113         d1i,d1j
24114 !       real(kind=8),dimension(3,2)::erhead_tail
24115 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
24116        real(kind=8) ::  facd4, adler, Fgb, facd3
24117        integer troll,jj,istate
24118        real (kind=8) :: dcosom1(3),dcosom2(3)
24119        eps_out=80.0d0
24120        sss_ele_cut=1.0d0
24121 !       print *,"EVDW KURW",evdw,nres
24122       do i=iatsc_s,iatsc_e
24123 !        print *,"I am in EVDW",i
24124         itypi=iabs(itype(i,1))
24125 !        if (i.ne.47) cycle
24126         if (itypi.eq.ntyp1) cycle
24127         itypi1=iabs(itype(i+1,1))
24128         xi=c(1,nres+i)
24129         yi=c(2,nres+i)
24130         zi=c(3,nres+i)
24131           xi=dmod(xi,boxxsize)
24132           if (xi.lt.0) xi=xi+boxxsize
24133           yi=dmod(yi,boxysize)
24134           if (yi.lt.0) yi=yi+boxysize
24135           zi=dmod(zi,boxzsize)
24136           if (zi.lt.0) zi=zi+boxzsize
24137
24138        if ((zi.gt.bordlipbot)  &
24139         .and.(zi.lt.bordliptop)) then
24140 !C the energy transfer exist
24141         if (zi.lt.buflipbot) then
24142 !C what fraction I am in
24143          fracinbuf=1.0d0-  &
24144               ((zi-bordlipbot)/lipbufthick)
24145 !C lipbufthick is thickenes of lipid buffore
24146          sslipi=sscalelip(fracinbuf)
24147          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
24148         elseif (zi.gt.bufliptop) then
24149          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
24150          sslipi=sscalelip(fracinbuf)
24151          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
24152         else
24153          sslipi=1.0d0
24154          ssgradlipi=0.0
24155         endif
24156        else
24157          sslipi=0.0d0
24158          ssgradlipi=0.0
24159        endif
24160 !       print *, sslipi,ssgradlipi
24161         dxi=dc_norm(1,nres+i)
24162         dyi=dc_norm(2,nres+i)
24163         dzi=dc_norm(3,nres+i)
24164 !        dsci_inv=dsc_inv(itypi)
24165         dsci_inv=vbld_inv(i+nres)
24166 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
24167 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
24168 !
24169 ! Calculate SC interaction energy.
24170 !
24171         do iint=1,nint_gr(i)
24172           do j=istart(i,iint),iend(i,iint)
24173 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
24174             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
24175               call dyn_ssbond_ene(i,j,evdwij)
24176               evdw=evdw+evdwij
24177               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
24178                               'evdw',i,j,evdwij,' ss'
24179 !              if (energy_dec) write (iout,*) &
24180 !                              'evdw',i,j,evdwij,' ss'
24181              do k=j+1,iend(i,iint)
24182 !C search over all next residues
24183               if (dyn_ss_mask(k)) then
24184 !C check if they are cysteins
24185 !C              write(iout,*) 'k=',k
24186
24187 !c              write(iout,*) "PRZED TRI", evdwij
24188 !               evdwij_przed_tri=evdwij
24189               call triple_ssbond_ene(i,j,k,evdwij)
24190 !c               if(evdwij_przed_tri.ne.evdwij) then
24191 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
24192 !c               endif
24193
24194 !c              write(iout,*) "PO TRI", evdwij
24195 !C call the energy function that removes the artifical triple disulfide
24196 !C bond the soubroutine is located in ssMD.F
24197               evdw=evdw+evdwij
24198               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
24199                             'evdw',i,j,evdwij,'tss'
24200               endif!dyn_ss_mask(k)
24201              enddo! k
24202             ELSE
24203 !el            ind=ind+1
24204             itypj=iabs(itype(j,1))
24205             if (itypj.eq.ntyp1) cycle
24206              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
24207
24208 !             if (j.ne.78) cycle
24209 !            dscj_inv=dsc_inv(itypj)
24210             dscj_inv=vbld_inv(j+nres)
24211            xj=c(1,j+nres)
24212            yj=c(2,j+nres)
24213            zj=c(3,j+nres)
24214            xj=dmod(xj,boxxsize)
24215            if (xj.lt.0) xj=xj+boxxsize
24216            yj=dmod(yj,boxysize)
24217            if (yj.lt.0) yj=yj+boxysize
24218            zj=dmod(zj,boxzsize)
24219            if (zj.lt.0) zj=zj+boxzsize
24220           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24221           xj_safe=xj
24222           yj_safe=yj
24223           zj_safe=zj
24224           subchap=0
24225
24226           do xshift=-1,1
24227           do yshift=-1,1
24228           do zshift=-1,1
24229           xj=xj_safe+xshift*boxxsize
24230           yj=yj_safe+yshift*boxysize
24231           zj=zj_safe+zshift*boxzsize
24232           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24233           if(dist_temp.lt.dist_init) then
24234             dist_init=dist_temp
24235             xj_temp=xj
24236             yj_temp=yj
24237             zj_temp=zj
24238             subchap=1
24239           endif
24240           enddo
24241           enddo
24242           enddo
24243           if (subchap.eq.1) then
24244           xj=xj_temp-xi
24245           yj=yj_temp-yi
24246           zj=zj_temp-zi
24247           else
24248           xj=xj_safe-xi
24249           yj=yj_safe-yi
24250           zj=zj_safe-zi
24251           endif
24252           dxj = dc_norm( 1, nres+j )
24253           dyj = dc_norm( 2, nres+j )
24254           dzj = dc_norm( 3, nres+j )
24255 !          print *,i,j,itypi,itypj
24256 !          d1i=0.0d0
24257 !          d1j=0.0d0
24258 !          BetaT = 1.0d0 / (298.0d0 * Rb)
24259 ! Gay-berne var's
24260 !1!          sig0ij = sigma_scsc( itypi,itypj )
24261 !          chi1=0.0d0
24262 !          chi2=0.0d0
24263 !          chip1=0.0d0
24264 !          chip2=0.0d0
24265 ! not used by momo potential, but needed by sc_angular which is shared
24266 ! by all energy_potential subroutines
24267           alf1   = 0.0d0
24268           alf2   = 0.0d0
24269           alf12  = 0.0d0
24270           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
24271 !       a12sq = a12sq * a12sq
24272 ! charge of amino acid itypi is...
24273           chis1 = chis(itypi,itypj)
24274           chis2 = chis(itypj,itypi)
24275           chis12 = chis1 * chis2
24276           sig1 = sigmap1(itypi,itypj)
24277           sig2 = sigmap2(itypi,itypj)
24278 !       write (*,*) "sig1 = ", sig1
24279 !          chis1=0.0
24280 !          chis2=0.0
24281 !                    chis12 = chis1 * chis2
24282 !          sig1=0.0
24283 !          sig2=0.0
24284 !       write (*,*) "sig2 = ", sig2
24285 ! alpha factors from Fcav/Gcav
24286           b1cav = alphasur(1,itypi,itypj)
24287 !          b1cav=0.0d0
24288           b2cav = alphasur(2,itypi,itypj)
24289           b3cav = alphasur(3,itypi,itypj)
24290           b4cav = alphasur(4,itypi,itypj)
24291 ! used to determine whether we want to do quadrupole calculations
24292        eps_in = epsintab(itypi,itypj)
24293        if (eps_in.eq.0.0) eps_in=1.0
24294
24295        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24296        Rtail = 0.0d0
24297 !       dtail(1,itypi,itypj)=0.0
24298 !       dtail(2,itypi,itypj)=0.0
24299
24300        DO k = 1, 3
24301         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
24302         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
24303        END DO
24304 !c! tail distances will be themselves usefull elswhere
24305 !c1 (in Gcav, for example)
24306        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
24307        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
24308        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
24309        Rtail = dsqrt( &
24310           (Rtail_distance(1)*Rtail_distance(1)) &
24311         + (Rtail_distance(2)*Rtail_distance(2)) &
24312         + (Rtail_distance(3)*Rtail_distance(3)))
24313
24314 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24315 !-------------------------------------------------------------------
24316 ! tail location and distance calculations
24317        d1 = dhead(1, 1, itypi, itypj)
24318        d2 = dhead(2, 1, itypi, itypj)
24319
24320        DO k = 1,3
24321 ! location of polar head is computed by taking hydrophobic centre
24322 ! and moving by a d1 * dc_norm vector
24323 ! see unres publications for very informative images
24324         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
24325         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
24326 ! distance
24327 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24328 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24329         Rhead_distance(k) = chead(k,2) - chead(k,1)
24330        END DO
24331 ! pitagoras (root of sum of squares)
24332        Rhead = dsqrt( &
24333           (Rhead_distance(1)*Rhead_distance(1)) &
24334         + (Rhead_distance(2)*Rhead_distance(2)) &
24335         + (Rhead_distance(3)*Rhead_distance(3)))
24336 !-------------------------------------------------------------------
24337 ! zero everything that should be zero'ed
24338        evdwij = 0.0d0
24339        ECL = 0.0d0
24340        Elj = 0.0d0
24341        Equad = 0.0d0
24342        Epol = 0.0d0
24343        Fcav=0.0d0
24344        eheadtail = 0.0d0
24345        dGCLdOM1 = 0.0d0
24346        dGCLdOM2 = 0.0d0
24347        dGCLdOM12 = 0.0d0
24348        dPOLdOM1 = 0.0d0
24349        dPOLdOM2 = 0.0d0
24350           Fcav = 0.0d0
24351           dFdR = 0.0d0
24352           dCAVdOM1  = 0.0d0
24353           dCAVdOM2  = 0.0d0
24354           dCAVdOM12 = 0.0d0
24355           dscj_inv = vbld_inv(j+nres)
24356 !          print *,i,j,dscj_inv,dsci_inv
24357 ! rij holds 1/(distance of Calpha atoms)
24358           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24359           rij  = dsqrt(rrij)
24360 !----------------------------
24361           CALL sc_angular
24362 ! this should be in elgrad_init but om's are calculated by sc_angular
24363 ! which in turn is used by older potentials
24364 ! om = omega, sqom = om^2
24365           sqom1  = om1 * om1
24366           sqom2  = om2 * om2
24367           sqom12 = om12 * om12
24368
24369 ! now we calculate EGB - Gey-Berne
24370 ! It will be summed up in evdwij and saved in evdw
24371           sigsq     = 1.0D0  / sigsq
24372           sig       = sig0ij * dsqrt(sigsq)
24373 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24374           rij_shift = Rtail - sig + sig0ij
24375           IF (rij_shift.le.0.0D0) THEN
24376            evdw = 1.0D20
24377            RETURN
24378           END IF
24379           sigder = -sig * sigsq
24380           rij_shift = 1.0D0 / rij_shift
24381           fac       = rij_shift**expon
24382           c1        = fac  * fac * aa_aq(itypi,itypj)
24383 !          print *,"ADAM",aa_aq(itypi,itypj)
24384
24385 !          c1        = 0.0d0
24386           c2        = fac  * bb_aq(itypi,itypj)
24387 !          c2        = 0.0d0
24388           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24389           eps2der   = eps3rt * evdwij
24390           eps3der   = eps2rt * evdwij
24391 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24392           evdwij    = eps2rt * eps3rt * evdwij
24393 !#ifdef TSCSC
24394 !          IF (bb_aq(itypi,itypj).gt.0) THEN
24395 !           evdw_p = evdw_p + evdwij
24396 !          ELSE
24397 !           evdw_m = evdw_m + evdwij
24398 !          END IF
24399 !#else
24400           evdw = evdw  &
24401               + evdwij
24402 !#endif
24403
24404           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24405           fac    = -expon * (c1 + evdwij) * rij_shift
24406           sigder = fac * sigder
24407 !          fac    = rij * fac
24408 ! Calculate distance derivative
24409           gg(1) =  fac
24410           gg(2) =  fac
24411           gg(3) =  fac
24412 !          if (b2.gt.0.0) then
24413           fac = chis1 * sqom1 + chis2 * sqom2 &
24414           - 2.0d0 * chis12 * om1 * om2 * om12
24415 ! we will use pom later in Gcav, so dont mess with it!
24416           pom = 1.0d0 - chis1 * chis2 * sqom12
24417           Lambf = (1.0d0 - (fac / pom))
24418 !          print *,"fac,pom",fac,pom,Lambf
24419           Lambf = dsqrt(Lambf)
24420           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24421 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
24422 !       write (*,*) "sparrow = ", sparrow
24423           Chif = Rtail * sparrow
24424 !           print *,"rij,sparrow",rij , sparrow
24425           ChiLambf = Chif * Lambf
24426           eagle = dsqrt(ChiLambf)
24427           bat = ChiLambf ** 11.0d0
24428           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
24429           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
24430           botsq = bot * bot
24431 !          print *,top,bot,"bot,top",ChiLambf,Chif
24432           Fcav = top / bot
24433
24434        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
24435        dbot = 12.0d0 * b4cav * bat * Lambf
24436        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24437
24438           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
24439           dbot = 12.0d0 * b4cav * bat * Chif
24440           eagle = Lambf * pom
24441           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24442           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24443           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24444               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24445
24446           dFdL = ((dtop * bot - top * dbot) / botsq)
24447 !       dFdL = 0.0d0
24448           dCAVdOM1  = dFdL * ( dFdOM1 )
24449           dCAVdOM2  = dFdL * ( dFdOM2 )
24450           dCAVdOM12 = dFdL * ( dFdOM12 )
24451
24452        DO k= 1, 3
24453         ertail(k) = Rtail_distance(k)/Rtail
24454        END DO
24455        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24456        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24457        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24458        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24459        DO k = 1, 3
24460 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24461 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24462         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24463         gvdwx(k,i) = gvdwx(k,i) &
24464                   - (( dFdR + gg(k) ) * pom)
24465 !c!     &             - ( dFdR * pom )
24466         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24467         gvdwx(k,j) = gvdwx(k,j)   &
24468                   + (( dFdR + gg(k) ) * pom)
24469 !c!     &             + ( dFdR * pom )
24470
24471         gvdwc(k,i) = gvdwc(k,i)  &
24472                   - (( dFdR + gg(k) ) * ertail(k))
24473 !c!     &             - ( dFdR * ertail(k))
24474
24475         gvdwc(k,j) = gvdwc(k,j) &
24476                   + (( dFdR + gg(k) ) * ertail(k))
24477 !c!     &             + ( dFdR * ertail(k))
24478
24479         gg(k) = 0.0d0
24480 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24481 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24482       END DO
24483
24484
24485 !c! Compute head-head and head-tail energies for each state
24486
24487           isel = iabs(Qi) + iabs(Qj)
24488 !          isel=0
24489           IF (isel.eq.0) THEN
24490 !c! No charges - do nothing
24491            eheadtail = 0.0d0
24492
24493           ELSE IF (isel.eq.4) THEN
24494 !c! Calculate dipole-dipole interactions
24495            CALL edd(ecl)
24496            eheadtail = ECL
24497 !           eheadtail = 0.0d0
24498
24499           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
24500 !c! Charge-nonpolar interactions
24501            CALL eqn(epol)
24502            eheadtail = epol
24503 !           eheadtail = 0.0d0
24504
24505           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
24506 !c! Nonpolar-charge interactions
24507            CALL enq(epol)
24508            eheadtail = epol
24509 !           eheadtail = 0.0d0
24510
24511           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
24512 !c! Charge-dipole interactions
24513            CALL eqd(ecl, elj, epol)
24514            eheadtail = ECL + elj + epol
24515 !           eheadtail = 0.0d0
24516
24517           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
24518 !c! Dipole-charge interactions
24519            CALL edq(ecl, elj, epol)
24520           eheadtail = ECL + elj + epol
24521 !           eheadtail = 0.0d0
24522
24523           ELSE IF ((isel.eq.2.and.   &
24524                iabs(Qi).eq.1).and.  &
24525                nstate(itypi,itypj).eq.1) THEN
24526 !c! Same charge-charge interaction ( +/+ or -/- )
24527            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
24528            eheadtail = ECL + Egb + Epol + Fisocav + Elj
24529 !           eheadtail = 0.0d0
24530
24531           ELSE IF ((isel.eq.2.and.  &
24532                iabs(Qi).eq.1).and. &
24533                nstate(itypi,itypj).ne.1) THEN
24534 !c! Different charge-charge interaction ( +/- or -/+ )
24535            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
24536           END IF
24537        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
24538       evdw = evdw  + Fcav + eheadtail
24539
24540        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24541         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24542         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24543         Equad,evdwij+Fcav+eheadtail,evdw
24544 !       evdw = evdw  + Fcav  + eheadtail
24545
24546         iF (nstate(itypi,itypj).eq.1) THEN
24547         CALL sc_grad
24548        END IF
24549 !c!-------------------------------------------------------------------
24550 !c! NAPISY KONCOWE
24551          END DO   ! j
24552         END DO    ! iint
24553        END DO     ! i
24554 !c      write (iout,*) "Number of loop steps in EGB:",ind
24555 !c      energy_dec=.false.
24556 !              print *,"EVDW KURW",evdw,nres
24557
24558        RETURN
24559       END SUBROUTINE emomo
24560 !C------------------------------------------------------------------------------------
24561       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
24562       use calc_data
24563       use comm_momo
24564        real (kind=8) ::  facd3, facd4, federmaus, adler,&
24565          Ecl,Egb,Epol,Fisocav,Elj,Fgb
24566 !       integer :: k
24567 !c! Epol and Gpol analytical parameters
24568        alphapol1 = alphapol(itypi,itypj)
24569        alphapol2 = alphapol(itypj,itypi)
24570 !c! Fisocav and Gisocav analytical parameters
24571        al1  = alphiso(1,itypi,itypj)
24572        al2  = alphiso(2,itypi,itypj)
24573        al3  = alphiso(3,itypi,itypj)
24574        al4  = alphiso(4,itypi,itypj)
24575        csig = (1.0d0  &
24576            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
24577            + sigiso2(itypi,itypj)**2.0d0))
24578 !c!
24579        pis  = sig0head(itypi,itypj)
24580        eps_head = epshead(itypi,itypj)
24581        Rhead_sq = Rhead * Rhead
24582 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24583 !c! R2 - distance between head of jth side chain and tail of ith sidechain
24584        R1 = 0.0d0
24585        R2 = 0.0d0
24586        DO k = 1, 3
24587 !c! Calculate head-to-tail distances needed by Epol
24588         R1=R1+(ctail(k,2)-chead(k,1))**2
24589         R2=R2+(chead(k,2)-ctail(k,1))**2
24590        END DO
24591 !c! Pitagoras
24592        R1 = dsqrt(R1)
24593        R2 = dsqrt(R2)
24594
24595 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24596 !c!     &        +dhead(1,1,itypi,itypj))**2))
24597 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24598 !c!     &        +dhead(2,1,itypi,itypj))**2))
24599
24600 !c!-------------------------------------------------------------------
24601 !c! Coulomb electrostatic interaction
24602        Ecl = (332.0d0 * Qij) / Rhead
24603 !c! derivative of Ecl is Gcl...
24604        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
24605        dGCLdOM1 = 0.0d0
24606        dGCLdOM2 = 0.0d0
24607        dGCLdOM12 = 0.0d0
24608        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
24609        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
24610        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
24611 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
24612 !c! Derivative of Egb is Ggb...
24613        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
24614        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
24615        dGGBdR = dGGBdFGB * dFGBdR
24616 !c!-------------------------------------------------------------------
24617 !c! Fisocav - isotropic cavity creation term
24618 !c! or "how much energy it costs to put charged head in water"
24619        pom = Rhead * csig
24620        top = al1 * (dsqrt(pom) + al2 * pom - al3)
24621        bot = (1.0d0 + al4 * pom**12.0d0)
24622        botsq = bot * bot
24623        FisoCav = top / bot
24624 !      write (*,*) "Rhead = ",Rhead
24625 !      write (*,*) "csig = ",csig
24626 !      write (*,*) "pom = ",pom
24627 !      write (*,*) "al1 = ",al1
24628 !      write (*,*) "al2 = ",al2
24629 !      write (*,*) "al3 = ",al3
24630 !      write (*,*) "al4 = ",al4
24631 !        write (*,*) "top = ",top
24632 !        write (*,*) "bot = ",bot
24633 !c! Derivative of Fisocav is GCV...
24634        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
24635        dbot = 12.0d0 * al4 * pom ** 11.0d0
24636        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
24637 !c!-------------------------------------------------------------------
24638 !c! Epol
24639 !c! Polarization energy - charged heads polarize hydrophobic "neck"
24640        MomoFac1 = (1.0d0 - chi1 * sqom2)
24641        MomoFac2 = (1.0d0 - chi2 * sqom1)
24642        RR1  = ( R1 * R1 ) / MomoFac1
24643        RR2  = ( R2 * R2 ) / MomoFac2
24644        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24645        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
24646        fgb1 = sqrt( RR1 + a12sq * ee1 )
24647        fgb2 = sqrt( RR2 + a12sq * ee2 )
24648        epol = 332.0d0 * eps_inout_fac * ( &
24649       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
24650 !c!       epol = 0.0d0
24651        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
24652                / (fgb1 ** 5.0d0)
24653        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
24654                / (fgb2 ** 5.0d0)
24655        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
24656              / ( 2.0d0 * fgb1 )
24657        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
24658              / ( 2.0d0 * fgb2 )
24659        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
24660                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
24661        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
24662                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
24663        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24664 !c!       dPOLdR1 = 0.0d0
24665        dPOLdR2 = dPOLdFGB2 * dFGBdR2
24666 !c!       dPOLdR2 = 0.0d0
24667        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
24668 !c!       dPOLdOM1 = 0.0d0
24669        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24670 !c!       dPOLdOM2 = 0.0d0
24671 !c!-------------------------------------------------------------------
24672 !c! Elj
24673 !c! Lennard-Jones 6-12 interaction between heads
24674        pom = (pis / Rhead)**6.0d0
24675        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
24676 !c! derivative of Elj is Glj
24677        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
24678              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
24679 !c!-------------------------------------------------------------------
24680 !c! Return the results
24681 !c! These things do the dRdX derivatives, that is
24682 !c! allow us to change what we see from function that changes with
24683 !c! distance to function that changes with LOCATION (of the interaction
24684 !c! site)
24685        DO k = 1, 3
24686         erhead(k) = Rhead_distance(k)/Rhead
24687         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
24688         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
24689        END DO
24690
24691        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24692        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24693        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24694        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24695        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
24696        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
24697        facd1 = d1 * vbld_inv(i+nres)
24698        facd2 = d2 * vbld_inv(j+nres)
24699        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24700        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24701
24702 !c! Now we add appropriate partial derivatives (one in each dimension)
24703        DO k = 1, 3
24704         hawk   = (erhead_tail(k,1) + &
24705         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
24706         condor = (erhead_tail(k,2) + &
24707         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
24708
24709         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24710         gvdwx(k,i) = gvdwx(k,i) &
24711                   - dGCLdR * pom&
24712                   - dGGBdR * pom&
24713                   - dGCVdR * pom&
24714                   - dPOLdR1 * hawk&
24715                   - dPOLdR2 * (erhead_tail(k,2)&
24716       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
24717                   - dGLJdR * pom
24718
24719         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24720         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
24721                    + dGGBdR * pom+ dGCVdR * pom&
24722                   + dPOLdR1 * (erhead_tail(k,1)&
24723       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
24724                   + dPOLdR2 * condor + dGLJdR * pom
24725
24726         gvdwc(k,i) = gvdwc(k,i)  &
24727                   - dGCLdR * erhead(k)&
24728                   - dGGBdR * erhead(k)&
24729                   - dGCVdR * erhead(k)&
24730                   - dPOLdR1 * erhead_tail(k,1)&
24731                   - dPOLdR2 * erhead_tail(k,2)&
24732                   - dGLJdR * erhead(k)
24733
24734         gvdwc(k,j) = gvdwc(k,j)         &
24735                   + dGCLdR * erhead(k) &
24736                   + dGGBdR * erhead(k) &
24737                   + dGCVdR * erhead(k) &
24738                   + dPOLdR1 * erhead_tail(k,1) &
24739                   + dPOLdR2 * erhead_tail(k,2)&
24740                   + dGLJdR * erhead(k)
24741
24742        END DO
24743        RETURN
24744       END SUBROUTINE eqq
24745 !c!-------------------------------------------------------------------
24746       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
24747       use comm_momo
24748       use calc_data
24749
24750        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
24751        double precision ener(4)
24752        double precision dcosom1(3),dcosom2(3)
24753 !c! used in Epol derivatives
24754        double precision facd3, facd4
24755        double precision federmaus, adler
24756        integer istate,ii,jj
24757        real (kind=8) :: Fgb
24758 !       print *,"CALLING EQUAD"
24759 !c! Epol and Gpol analytical parameters
24760        alphapol1 = alphapol(itypi,itypj)
24761        alphapol2 = alphapol(itypj,itypi)
24762 !c! Fisocav and Gisocav analytical parameters
24763        al1  = alphiso(1,itypi,itypj)
24764        al2  = alphiso(2,itypi,itypj)
24765        al3  = alphiso(3,itypi,itypj)
24766        al4  = alphiso(4,itypi,itypj)
24767        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
24768             + sigiso2(itypi,itypj)**2.0d0))
24769 !c!
24770        w1   = wqdip(1,itypi,itypj)
24771        w2   = wqdip(2,itypi,itypj)
24772        pis  = sig0head(itypi,itypj)
24773        eps_head = epshead(itypi,itypj)
24774 !c! First things first:
24775 !c! We need to do sc_grad's job with GB and Fcav
24776        eom1  = eps2der * eps2rt_om1 &
24777              - 2.0D0 * alf1 * eps3der&
24778              + sigder * sigsq_om1&
24779              + dCAVdOM1
24780        eom2  = eps2der * eps2rt_om2 &
24781              + 2.0D0 * alf2 * eps3der&
24782              + sigder * sigsq_om2&
24783              + dCAVdOM2
24784        eom12 =  evdwij  * eps1_om12 &
24785              + eps2der * eps2rt_om12 &
24786              - 2.0D0 * alf12 * eps3der&
24787              + sigder *sigsq_om12&
24788              + dCAVdOM12
24789 !c! now some magical transformations to project gradient into
24790 !c! three cartesian vectors
24791        DO k = 1, 3
24792         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24793         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24794         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24795 !c! this acts on hydrophobic center of interaction
24796         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
24797                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
24798                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24799         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
24800                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
24801                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24802 !c! this acts on Calpha
24803         gvdwc(k,i)=gvdwc(k,i)-gg(k)
24804         gvdwc(k,j)=gvdwc(k,j)+gg(k)
24805        END DO
24806 !c! sc_grad is done, now we will compute
24807        eheadtail = 0.0d0
24808        eom1 = 0.0d0
24809        eom2 = 0.0d0
24810        eom12 = 0.0d0
24811        DO istate = 1, nstate(itypi,itypj)
24812 !c*************************************************************
24813         IF (istate.ne.1) THEN
24814          IF (istate.lt.3) THEN
24815           ii = 1
24816          ELSE
24817           ii = 2
24818          END IF
24819         jj = istate/ii
24820         d1 = dhead(1,ii,itypi,itypj)
24821         d2 = dhead(2,jj,itypi,itypj)
24822         DO k = 1,3
24823          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
24824          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
24825          Rhead_distance(k) = chead(k,2) - chead(k,1)
24826         END DO
24827 !c! pitagoras (root of sum of squares)
24828         Rhead = dsqrt( &
24829                (Rhead_distance(1)*Rhead_distance(1))  &
24830              + (Rhead_distance(2)*Rhead_distance(2))  &
24831              + (Rhead_distance(3)*Rhead_distance(3)))
24832         END IF
24833         Rhead_sq = Rhead * Rhead
24834
24835 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24836 !c! R2 - distance between head of jth side chain and tail of ith sidechain
24837         R1 = 0.0d0
24838         R2 = 0.0d0
24839         DO k = 1, 3
24840 !c! Calculate head-to-tail distances
24841          R1=R1+(ctail(k,2)-chead(k,1))**2
24842          R2=R2+(chead(k,2)-ctail(k,1))**2
24843         END DO
24844 !c! Pitagoras
24845         R1 = dsqrt(R1)
24846         R2 = dsqrt(R2)
24847         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
24848 !c!        Ecl = 0.0d0
24849 !c!        write (*,*) "Ecl = ", Ecl
24850 !c! derivative of Ecl is Gcl...
24851         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
24852 !c!        dGCLdR = 0.0d0
24853         dGCLdOM1 = 0.0d0
24854         dGCLdOM2 = 0.0d0
24855         dGCLdOM12 = 0.0d0
24856 !c!-------------------------------------------------------------------
24857 !c! Generalised Born Solvent Polarization
24858         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
24859         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
24860         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
24861 !c!        Egb = 0.0d0
24862 !c!      write (*,*) "a1*a2 = ", a12sq
24863 !c!      write (*,*) "Rhead = ", Rhead
24864 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
24865 !c!      write (*,*) "ee = ", ee
24866 !c!      write (*,*) "Fgb = ", Fgb
24867 !c!      write (*,*) "fac = ", eps_inout_fac
24868 !c!      write (*,*) "Qij = ", Qij
24869 !c!      write (*,*) "Egb = ", Egb
24870 !c! Derivative of Egb is Ggb...
24871 !c! dFGBdR is used by Quad's later...
24872         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
24873         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
24874                / ( 2.0d0 * Fgb )
24875         dGGBdR = dGGBdFGB * dFGBdR
24876 !c!        dGGBdR = 0.0d0
24877 !c!-------------------------------------------------------------------
24878 !c! Fisocav - isotropic cavity creation term
24879         pom = Rhead * csig
24880         top = al1 * (dsqrt(pom) + al2 * pom - al3)
24881         bot = (1.0d0 + al4 * pom**12.0d0)
24882         botsq = bot * bot
24883         FisoCav = top / bot
24884         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
24885         dbot = 12.0d0 * al4 * pom ** 11.0d0
24886         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
24887 !c!        dGCVdR = 0.0d0
24888 !c!-------------------------------------------------------------------
24889 !c! Polarization energy
24890 !c! Epol
24891         MomoFac1 = (1.0d0 - chi1 * sqom2)
24892         MomoFac2 = (1.0d0 - chi2 * sqom1)
24893         RR1  = ( R1 * R1 ) / MomoFac1
24894         RR2  = ( R2 * R2 ) / MomoFac2
24895         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24896         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
24897         fgb1 = sqrt( RR1 + a12sq * ee1 )
24898         fgb2 = sqrt( RR2 + a12sq * ee2 )
24899         epol = 332.0d0 * eps_inout_fac * (&
24900         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
24901 !c!        epol = 0.0d0
24902 !c! derivative of Epol is Gpol...
24903         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
24904                   / (fgb1 ** 5.0d0)
24905         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
24906                   / (fgb2 ** 5.0d0)
24907         dFGBdR1 = ( (R1 / MomoFac1) &
24908                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
24909                 / ( 2.0d0 * fgb1 )
24910         dFGBdR2 = ( (R2 / MomoFac2) &
24911                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
24912                 / ( 2.0d0 * fgb2 )
24913         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24914                  * ( 2.0d0 - 0.5d0 * ee1) ) &
24915                  / ( 2.0d0 * fgb1 )
24916         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
24917                  * ( 2.0d0 - 0.5d0 * ee2) ) &
24918                  / ( 2.0d0 * fgb2 )
24919         dPOLdR1 = dPOLdFGB1 * dFGBdR1
24920 !c!        dPOLdR1 = 0.0d0
24921         dPOLdR2 = dPOLdFGB2 * dFGBdR2
24922 !c!        dPOLdR2 = 0.0d0
24923         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
24924 !c!        dPOLdOM1 = 0.0d0
24925         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24926         pom = (pis / Rhead)**6.0d0
24927         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
24928 !c!        Elj = 0.0d0
24929 !c! derivative of Elj is Glj
24930         dGLJdR = 4.0d0 * eps_head &
24931             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
24932             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
24933 !c!        dGLJdR = 0.0d0
24934 !c!-------------------------------------------------------------------
24935 !c! Equad
24936        IF (Wqd.ne.0.0d0) THEN
24937         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
24938              - 37.5d0  * ( sqom1 + sqom2 ) &
24939              + 157.5d0 * ( sqom1 * sqom2 ) &
24940              - 45.0d0  * om1*om2*om12
24941         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
24942         Equad = fac * Beta1
24943 !c!        Equad = 0.0d0
24944 !c! derivative of Equad...
24945         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
24946 !c!        dQUADdR = 0.0d0
24947         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
24948 !c!        dQUADdOM1 = 0.0d0
24949         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
24950 !c!        dQUADdOM2 = 0.0d0
24951         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
24952        ELSE
24953          Beta1 = 0.0d0
24954          Equad = 0.0d0
24955         END IF
24956 !c!-------------------------------------------------------------------
24957 !c! Return the results
24958 !c! Angular stuff
24959         eom1 = dPOLdOM1 + dQUADdOM1
24960         eom2 = dPOLdOM2 + dQUADdOM2
24961         eom12 = dQUADdOM12
24962 !c! now some magical transformations to project gradient into
24963 !c! three cartesian vectors
24964         DO k = 1, 3
24965          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24966          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24967          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
24968         END DO
24969 !c! Radial stuff
24970         DO k = 1, 3
24971          erhead(k) = Rhead_distance(k)/Rhead
24972          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
24973          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
24974         END DO
24975         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24976         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24977         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24978         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24979         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
24980         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
24981         facd1 = d1 * vbld_inv(i+nres)
24982         facd2 = d2 * vbld_inv(j+nres)
24983         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24984         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24985         DO k = 1, 3
24986          hawk   = erhead_tail(k,1) + &
24987          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
24988          condor = erhead_tail(k,2) + &
24989          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
24990
24991          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24992 !c! this acts on hydrophobic center of interaction
24993          gheadtail(k,1,1) = gheadtail(k,1,1) &
24994                          - dGCLdR * pom &
24995                          - dGGBdR * pom &
24996                          - dGCVdR * pom &
24997                          - dPOLdR1 * hawk &
24998                          - dPOLdR2 * (erhead_tail(k,2) &
24999       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25000                          - dGLJdR * pom &
25001                          - dQUADdR * pom&
25002                          - tuna(k) &
25003                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25004                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25005
25006          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25007 !c! this acts on hydrophobic center of interaction
25008          gheadtail(k,2,1) = gheadtail(k,2,1)  &
25009                          + dGCLdR * pom      &
25010                          + dGGBdR * pom      &
25011                          + dGCVdR * pom      &
25012                          + dPOLdR1 * (erhead_tail(k,1) &
25013       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25014                          + dPOLdR2 * condor &
25015                          + dGLJdR * pom &
25016                          + dQUADdR * pom &
25017                          + tuna(k) &
25018                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25019                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25020
25021 !c! this acts on Calpha
25022          gheadtail(k,3,1) = gheadtail(k,3,1)  &
25023                          - dGCLdR * erhead(k)&
25024                          - dGGBdR * erhead(k)&
25025                          - dGCVdR * erhead(k)&
25026                          - dPOLdR1 * erhead_tail(k,1)&
25027                          - dPOLdR2 * erhead_tail(k,2)&
25028                          - dGLJdR * erhead(k) &
25029                          - dQUADdR * erhead(k)&
25030                          - tuna(k)
25031 !c! this acts on Calpha
25032          gheadtail(k,4,1) = gheadtail(k,4,1)   &
25033                           + dGCLdR * erhead(k) &
25034                           + dGGBdR * erhead(k) &
25035                           + dGCVdR * erhead(k) &
25036                           + dPOLdR1 * erhead_tail(k,1) &
25037                           + dPOLdR2 * erhead_tail(k,2) &
25038                           + dGLJdR * erhead(k) &
25039                           + dQUADdR * erhead(k)&
25040                           + tuna(k)
25041         END DO
25042         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
25043         eheadtail = eheadtail &
25044                   + wstate(istate, itypi, itypj) &
25045                   * dexp(-betaT * ener(istate))
25046 !c! foreach cartesian dimension
25047         DO k = 1, 3
25048 !c! foreach of two gvdwx and gvdwc
25049          DO l = 1, 4
25050           gheadtail(k,l,2) = gheadtail(k,l,2)  &
25051                            + wstate( istate, itypi, itypj ) &
25052                            * dexp(-betaT * ener(istate)) &
25053                            * gheadtail(k,l,1)
25054           gheadtail(k,l,1) = 0.0d0
25055          END DO
25056         END DO
25057        END DO
25058 !c! Here ended the gigantic DO istate = 1, 4, which starts
25059 !c! at the beggining of the subroutine
25060
25061        DO k = 1, 3
25062         DO l = 1, 4
25063          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
25064         END DO
25065         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
25066         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
25067         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
25068         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
25069         DO l = 1, 4
25070          gheadtail(k,l,1) = 0.0d0
25071          gheadtail(k,l,2) = 0.0d0
25072         END DO
25073        END DO
25074        eheadtail = (-dlog(eheadtail)) / betaT
25075        dPOLdOM1 = 0.0d0
25076        dPOLdOM2 = 0.0d0
25077        dQUADdOM1 = 0.0d0
25078        dQUADdOM2 = 0.0d0
25079        dQUADdOM12 = 0.0d0
25080        RETURN
25081       END SUBROUTINE energy_quad
25082 !!-----------------------------------------------------------
25083       SUBROUTINE eqn(Epol)
25084       use comm_momo
25085       use calc_data
25086
25087       double precision  facd4, federmaus,epol
25088       alphapol1 = alphapol(itypi,itypj)
25089 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25090        R1 = 0.0d0
25091        DO k = 1, 3
25092 !c! Calculate head-to-tail distances
25093         R1=R1+(ctail(k,2)-chead(k,1))**2
25094        END DO
25095 !c! Pitagoras
25096        R1 = dsqrt(R1)
25097
25098 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25099 !c!     &        +dhead(1,1,itypi,itypj))**2))
25100 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25101 !c!     &        +dhead(2,1,itypi,itypj))**2))
25102 !c--------------------------------------------------------------------
25103 !c Polarization energy
25104 !c Epol
25105        MomoFac1 = (1.0d0 - chi1 * sqom2)
25106        RR1  = R1 * R1 / MomoFac1
25107        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25108        fgb1 = sqrt( RR1 + a12sq * ee1)
25109        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25110        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25111                / (fgb1 ** 5.0d0)
25112        dFGBdR1 = ( (R1 / MomoFac1) &
25113               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25114               / ( 2.0d0 * fgb1 )
25115        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25116                 * (2.0d0 - 0.5d0 * ee1) ) &
25117                 / (2.0d0 * fgb1)
25118        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25119 !c!       dPOLdR1 = 0.0d0
25120        dPOLdOM1 = 0.0d0
25121        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25122        DO k = 1, 3
25123         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25124        END DO
25125        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25126        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25127        facd1 = d1 * vbld_inv(i+nres)
25128        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25129
25130        DO k = 1, 3
25131         hawk = (erhead_tail(k,1) + &
25132         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25133
25134         gvdwx(k,i) = gvdwx(k,i) &
25135                    - dPOLdR1 * hawk
25136         gvdwx(k,j) = gvdwx(k,j) &
25137                    + dPOLdR1 * (erhead_tail(k,1) &
25138        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
25139
25140         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
25141         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
25142
25143        END DO
25144        RETURN
25145       END SUBROUTINE eqn
25146       SUBROUTINE enq(Epol)
25147       use calc_data
25148       use comm_momo
25149        double precision facd3, adler,epol
25150        alphapol2 = alphapol(itypj,itypi)
25151 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25152        R2 = 0.0d0
25153        DO k = 1, 3
25154 !c! Calculate head-to-tail distances
25155         R2=R2+(chead(k,2)-ctail(k,1))**2
25156        END DO
25157 !c! Pitagoras
25158        R2 = dsqrt(R2)
25159
25160 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25161 !c!     &        +dhead(1,1,itypi,itypj))**2))
25162 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25163 !c!     &        +dhead(2,1,itypi,itypj))**2))
25164 !c------------------------------------------------------------------------
25165 !c Polarization energy
25166        MomoFac2 = (1.0d0 - chi2 * sqom1)
25167        RR2  = R2 * R2 / MomoFac2
25168        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
25169        fgb2 = sqrt(RR2  + a12sq * ee2)
25170        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
25171        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
25172                 / (fgb2 ** 5.0d0)
25173        dFGBdR2 = ( (R2 / MomoFac2)  &
25174               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25175               / (2.0d0 * fgb2)
25176        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25177                 * (2.0d0 - 0.5d0 * ee2) ) &
25178                 / (2.0d0 * fgb2)
25179        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25180 !c!       dPOLdR2 = 0.0d0
25181        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25182 !c!       dPOLdOM1 = 0.0d0
25183        dPOLdOM2 = 0.0d0
25184 !c!-------------------------------------------------------------------
25185 !c! Return the results
25186 !c! (See comments in Eqq)
25187        DO k = 1, 3
25188         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25189        END DO
25190        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25191        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25192        facd2 = d2 * vbld_inv(j+nres)
25193        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25194        DO k = 1, 3
25195         condor = (erhead_tail(k,2) &
25196        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25197
25198         gvdwx(k,i) = gvdwx(k,i) &
25199                    - dPOLdR2 * (erhead_tail(k,2) &
25200        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
25201         gvdwx(k,j) = gvdwx(k,j)   &
25202                    + dPOLdR2 * condor
25203
25204         gvdwc(k,i) = gvdwc(k,i) &
25205                    - dPOLdR2 * erhead_tail(k,2)
25206         gvdwc(k,j) = gvdwc(k,j) &
25207                    + dPOLdR2 * erhead_tail(k,2)
25208
25209        END DO
25210       RETURN
25211       END SUBROUTINE enq
25212       SUBROUTINE eqd(Ecl,Elj,Epol)
25213       use calc_data
25214       use comm_momo
25215        double precision  facd4, federmaus,ecl,elj,epol
25216        alphapol1 = alphapol(itypi,itypj)
25217        w1        = wqdip(1,itypi,itypj)
25218        w2        = wqdip(2,itypi,itypj)
25219        pis       = sig0head(itypi,itypj)
25220        eps_head   = epshead(itypi,itypj)
25221 !c!-------------------------------------------------------------------
25222 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25223        R1 = 0.0d0
25224        DO k = 1, 3
25225 !c! Calculate head-to-tail distances
25226         R1=R1+(ctail(k,2)-chead(k,1))**2
25227        END DO
25228 !c! Pitagoras
25229        R1 = dsqrt(R1)
25230
25231 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25232 !c!     &        +dhead(1,1,itypi,itypj))**2))
25233 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25234 !c!     &        +dhead(2,1,itypi,itypj))**2))
25235
25236 !c!-------------------------------------------------------------------
25237 !c! ecl
25238        sparrow  = w1 * Qi * om1
25239        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
25240        Ecl = sparrow / Rhead**2.0d0 &
25241            - hawk    / Rhead**4.0d0
25242        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25243                  + 4.0d0 * hawk    / Rhead**5.0d0
25244 !c! dF/dom1
25245        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
25246 !c! dF/dom2
25247        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
25248 !c--------------------------------------------------------------------
25249 !c Polarization energy
25250 !c Epol
25251        MomoFac1 = (1.0d0 - chi1 * sqom2)
25252        RR1  = R1 * R1 / MomoFac1
25253        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25254        fgb1 = sqrt( RR1 + a12sq * ee1)
25255        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25256 !c!       epol = 0.0d0
25257 !c!------------------------------------------------------------------
25258 !c! derivative of Epol is Gpol...
25259        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25260                / (fgb1 ** 5.0d0)
25261        dFGBdR1 = ( (R1 / MomoFac1)  &
25262              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25263              / ( 2.0d0 * fgb1 )
25264        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25265                * (2.0d0 - 0.5d0 * ee1) ) &
25266                / (2.0d0 * fgb1)
25267        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25268 !c!       dPOLdR1 = 0.0d0
25269        dPOLdOM1 = 0.0d0
25270        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25271 !c!       dPOLdOM2 = 0.0d0
25272 !c!-------------------------------------------------------------------
25273 !c! Elj
25274        pom = (pis / Rhead)**6.0d0
25275        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25276 !c! derivative of Elj is Glj
25277        dGLJdR = 4.0d0 * eps_head &
25278           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25279           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25280        DO k = 1, 3
25281         erhead(k) = Rhead_distance(k)/Rhead
25282         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25283        END DO
25284
25285        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25286        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25287        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25288        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25289        facd1 = d1 * vbld_inv(i+nres)
25290        facd2 = d2 * vbld_inv(j+nres)
25291        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25292
25293        DO k = 1, 3
25294         hawk = (erhead_tail(k,1) +  &
25295         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25296
25297         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25298         gvdwx(k,i) = gvdwx(k,i)  &
25299                    - dGCLdR * pom&
25300                    - dPOLdR1 * hawk &
25301                    - dGLJdR * pom
25302
25303         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25304         gvdwx(k,j) = gvdwx(k,j)    &
25305                    + dGCLdR * pom  &
25306                    + dPOLdR1 * (erhead_tail(k,1) &
25307        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25308                    + dGLJdR * pom
25309
25310
25311         gvdwc(k,i) = gvdwc(k,i)          &
25312                    - dGCLdR * erhead(k)  &
25313                    - dPOLdR1 * erhead_tail(k,1) &
25314                    - dGLJdR * erhead(k)
25315
25316         gvdwc(k,j) = gvdwc(k,j)          &
25317                    + dGCLdR * erhead(k)  &
25318                    + dPOLdR1 * erhead_tail(k,1) &
25319                    + dGLJdR * erhead(k)
25320
25321        END DO
25322        RETURN
25323       END SUBROUTINE eqd
25324       SUBROUTINE edq(Ecl,Elj,Epol)
25325 !       IMPLICIT NONE
25326        use comm_momo
25327       use calc_data
25328
25329       double precision  facd3, adler,ecl,elj,epol
25330        alphapol2 = alphapol(itypj,itypi)
25331        w1        = wqdip(1,itypi,itypj)
25332        w2        = wqdip(2,itypi,itypj)
25333        pis       = sig0head(itypi,itypj)
25334        eps_head  = epshead(itypi,itypj)
25335 !c!-------------------------------------------------------------------
25336 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25337        R2 = 0.0d0
25338        DO k = 1, 3
25339 !c! Calculate head-to-tail distances
25340         R2=R2+(chead(k,2)-ctail(k,1))**2
25341        END DO
25342 !c! Pitagoras
25343        R2 = dsqrt(R2)
25344
25345 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25346 !c!     &        +dhead(1,1,itypi,itypj))**2))
25347 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25348 !c!     &        +dhead(2,1,itypi,itypj))**2))
25349
25350
25351 !c!-------------------------------------------------------------------
25352 !c! ecl
25353        sparrow  = w1 * Qi * om1
25354        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
25355        ECL = sparrow / Rhead**2.0d0 &
25356            - hawk    / Rhead**4.0d0
25357 !c!-------------------------------------------------------------------
25358 !c! derivative of ecl is Gcl
25359 !c! dF/dr part
25360        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25361                  + 4.0d0 * hawk    / Rhead**5.0d0
25362 !c! dF/dom1
25363        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
25364 !c! dF/dom2
25365        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
25366 !c--------------------------------------------------------------------
25367 !c Polarization energy
25368 !c Epol
25369        MomoFac2 = (1.0d0 - chi2 * sqom1)
25370        RR2  = R2 * R2 / MomoFac2
25371        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
25372        fgb2 = sqrt(RR2  + a12sq * ee2)
25373        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
25374        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
25375                / (fgb2 ** 5.0d0)
25376        dFGBdR2 = ( (R2 / MomoFac2)  &
25377                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25378                / (2.0d0 * fgb2)
25379        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25380                 * (2.0d0 - 0.5d0 * ee2) ) &
25381                 / (2.0d0 * fgb2)
25382        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25383 !c!       dPOLdR2 = 0.0d0
25384        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25385 !c!       dPOLdOM1 = 0.0d0
25386        dPOLdOM2 = 0.0d0
25387 !c!-------------------------------------------------------------------
25388 !c! Elj
25389        pom = (pis / Rhead)**6.0d0
25390        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25391 !c! derivative of Elj is Glj
25392        dGLJdR = 4.0d0 * eps_head &
25393            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25394            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25395 !c!-------------------------------------------------------------------
25396 !c! Return the results
25397 !c! (see comments in Eqq)
25398        DO k = 1, 3
25399         erhead(k) = Rhead_distance(k)/Rhead
25400         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25401        END DO
25402        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25403        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25404        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25405        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25406        facd1 = d1 * vbld_inv(i+nres)
25407        facd2 = d2 * vbld_inv(j+nres)
25408        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25409        DO k = 1, 3
25410         condor = (erhead_tail(k,2) &
25411        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25412
25413         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25414         gvdwx(k,i) = gvdwx(k,i) &
25415                   - dGCLdR * pom &
25416                   - dPOLdR2 * (erhead_tail(k,2) &
25417        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
25418                   - dGLJdR * pom
25419
25420         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25421         gvdwx(k,j) = gvdwx(k,j) &
25422                   + dGCLdR * pom &
25423                   + dPOLdR2 * condor &
25424                   + dGLJdR * pom
25425
25426
25427         gvdwc(k,i) = gvdwc(k,i) &
25428                   - dGCLdR * erhead(k) &
25429                   - dPOLdR2 * erhead_tail(k,2) &
25430                   - dGLJdR * erhead(k)
25431
25432         gvdwc(k,j) = gvdwc(k,j) &
25433                   + dGCLdR * erhead(k) &
25434                   + dPOLdR2 * erhead_tail(k,2) &
25435                   + dGLJdR * erhead(k)
25436
25437        END DO
25438        RETURN
25439       END SUBROUTINE edq
25440       SUBROUTINE edd(ECL)
25441 !       IMPLICIT NONE
25442        use comm_momo
25443       use calc_data
25444
25445        double precision ecl
25446 !c!       csig = sigiso(itypi,itypj)
25447        w1 = wqdip(1,itypi,itypj)
25448        w2 = wqdip(2,itypi,itypj)
25449 !c!-------------------------------------------------------------------
25450 !c! ECL
25451        fac = (om12 - 3.0d0 * om1 * om2)
25452        c1 = (w1 / (Rhead**3.0d0)) * fac
25453        c2 = (w2 / Rhead ** 6.0d0) &
25454           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25455        ECL = c1 - c2
25456 !c!       write (*,*) "w1 = ", w1
25457 !c!       write (*,*) "w2 = ", w2
25458 !c!       write (*,*) "om1 = ", om1
25459 !c!       write (*,*) "om2 = ", om2
25460 !c!       write (*,*) "om12 = ", om12
25461 !c!       write (*,*) "fac = ", fac
25462 !c!       write (*,*) "c1 = ", c1
25463 !c!       write (*,*) "c2 = ", c2
25464 !c!       write (*,*) "Ecl = ", Ecl
25465 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
25466 !c!       write (*,*) "c2_2 = ",
25467 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25468 !c!-------------------------------------------------------------------
25469 !c! dervative of ECL is GCL...
25470 !c! dECL/dr
25471        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25472        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25473           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25474        dGCLdR = c1 - c2
25475 !c! dECL/dom1
25476        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25477        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25478           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25479        dGCLdOM1 = c1 - c2
25480 !c! dECL/dom2
25481        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25482        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25483           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25484        dGCLdOM2 = c1 - c2
25485 !c! dECL/dom12
25486        c1 = w1 / (Rhead ** 3.0d0)
25487        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25488        dGCLdOM12 = c1 - c2
25489 !c!-------------------------------------------------------------------
25490 !c! Return the results
25491 !c! (see comments in Eqq)
25492        DO k= 1, 3
25493         erhead(k) = Rhead_distance(k)/Rhead
25494        END DO
25495        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25496        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25497        facd1 = d1 * vbld_inv(i+nres)
25498        facd2 = d2 * vbld_inv(j+nres)
25499        DO k = 1, 3
25500
25501         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25502         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
25503         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25504         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
25505
25506         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
25507         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
25508        END DO
25509        RETURN
25510       END SUBROUTINE edd
25511       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25512 !       IMPLICIT NONE
25513        use comm_momo
25514       use calc_data
25515
25516        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
25517        eps_out=80.0d0
25518        itypi = itype(i,1)
25519        itypj = itype(j,1)
25520 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
25521 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
25522 !c!       t_bath = 300
25523 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
25524        Rb=0.001986d0
25525        BetaT = 1.0d0 / (298.0d0 * Rb)
25526 !c! Gay-berne var's
25527        sig0ij = sigma( itypi,itypj )
25528        chi1   = chi( itypi, itypj )
25529        chi2   = chi( itypj, itypi )
25530        chi12  = chi1 * chi2
25531        chip1  = chipp( itypi, itypj )
25532        chip2  = chipp( itypj, itypi )
25533        chip12 = chip1 * chip2
25534 !       chi1=0.0
25535 !       chi2=0.0
25536 !       chi12=0.0
25537 !       chip1=0.0
25538 !       chip2=0.0
25539 !       chip12=0.0
25540 !c! not used by momo potential, but needed by sc_angular which is shared
25541 !c! by all energy_potential subroutines
25542        alf1   = 0.0d0
25543        alf2   = 0.0d0
25544        alf12  = 0.0d0
25545 !c! location, location, location
25546 !       xj  = c( 1, nres+j ) - xi
25547 !       yj  = c( 2, nres+j ) - yi
25548 !       zj  = c( 3, nres+j ) - zi
25549        dxj = dc_norm( 1, nres+j )
25550        dyj = dc_norm( 2, nres+j )
25551        dzj = dc_norm( 3, nres+j )
25552 !c! distance from center of chain(?) to polar/charged head
25553 !c!       write (*,*) "istate = ", 1
25554 !c!       write (*,*) "ii = ", 1
25555 !c!       write (*,*) "jj = ", 1
25556        d1 = dhead(1, 1, itypi, itypj)
25557        d2 = dhead(2, 1, itypi, itypj)
25558 !c! ai*aj from Fgb
25559        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25560 !c!       a12sq = a12sq * a12sq
25561 !c! charge of amino acid itypi is...
25562        Qi  = icharge(itypi)
25563        Qj  = icharge(itypj)
25564        Qij = Qi * Qj
25565 !c! chis1,2,12
25566        chis1 = chis(itypi,itypj)
25567        chis2 = chis(itypj,itypi)
25568        chis12 = chis1 * chis2
25569        sig1 = sigmap1(itypi,itypj)
25570        sig2 = sigmap2(itypi,itypj)
25571 !c!       write (*,*) "sig1 = ", sig1
25572 !c!       write (*,*) "sig2 = ", sig2
25573 !c! alpha factors from Fcav/Gcav
25574        b1cav = alphasur(1,itypi,itypj)
25575 !       b1cav=0.0
25576        b2cav = alphasur(2,itypi,itypj)
25577        b3cav = alphasur(3,itypi,itypj)
25578        b4cav = alphasur(4,itypi,itypj)
25579        wqd = wquad(itypi, itypj)
25580 !c! used by Fgb
25581        eps_in = epsintab(itypi,itypj)
25582        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25583 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
25584 !c!-------------------------------------------------------------------
25585 !c! tail location and distance calculations
25586        Rtail = 0.0d0
25587        DO k = 1, 3
25588         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25589         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25590        END DO
25591 !c! tail distances will be themselves usefull elswhere
25592 !c1 (in Gcav, for example)
25593        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25594        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25595        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25596        Rtail = dsqrt(  &
25597           (Rtail_distance(1)*Rtail_distance(1))  &
25598         + (Rtail_distance(2)*Rtail_distance(2))  &
25599         + (Rtail_distance(3)*Rtail_distance(3)))
25600 !c!-------------------------------------------------------------------
25601 !c! Calculate location and distance between polar heads
25602 !c! distance between heads
25603 !c! for each one of our three dimensional space...
25604        d1 = dhead(1, 1, itypi, itypj)
25605        d2 = dhead(2, 1, itypi, itypj)
25606
25607        DO k = 1,3
25608 !c! location of polar head is computed by taking hydrophobic centre
25609 !c! and moving by a d1 * dc_norm vector
25610 !c! see unres publications for very informative images
25611         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25612         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25613 !c! distance
25614 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25615 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25616         Rhead_distance(k) = chead(k,2) - chead(k,1)
25617        END DO
25618 !c! pitagoras (root of sum of squares)
25619        Rhead = dsqrt(   &
25620           (Rhead_distance(1)*Rhead_distance(1)) &
25621         + (Rhead_distance(2)*Rhead_distance(2)) &
25622         + (Rhead_distance(3)*Rhead_distance(3)))
25623 !c!-------------------------------------------------------------------
25624 !c! zero everything that should be zero'ed
25625        Egb = 0.0d0
25626        ECL = 0.0d0
25627        Elj = 0.0d0
25628        Equad = 0.0d0
25629        Epol = 0.0d0
25630        eheadtail = 0.0d0
25631        dGCLdOM1 = 0.0d0
25632        dGCLdOM2 = 0.0d0
25633        dGCLdOM12 = 0.0d0
25634        dPOLdOM1 = 0.0d0
25635        dPOLdOM2 = 0.0d0
25636        RETURN
25637       END SUBROUTINE elgrad_init
25638       end module energy