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          call egb(evdw)
 397 !      goto 107
 398 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 399 !  105 call egbv(evdw)
 400        case (5)
 401          call egbv(evdw)
 402 !      goto 107
 403 ! Soft-sphere potential
 404 !  106 call e_softsphere(evdw)
 405        case (6)
 406          call e_softsphere(evdw)
 407 !
 408 ! Calculate electrostatic (H-bonding) energy of the main chain.
 409 !
 410 !  107 continue
 411        case default
 412          write(iout,*)"Wrong ipot"
 413 !         return
 414 !   50 continue
 415       end select
 416 !      continue
 417 !        print *,"after EGB"
 418 ! shielding effect
 419        if (shield_mode.eq.2) then
 420                  call set_shield_fac2
 421        endif
 422 !       print *,"AFTER EGB",ipot,evdw
 423 !mc
 424 !mc Sep-06: egb takes care of dynamic ss bonds too
 425 !mc
 426 !      if (dyn_ss) call dyn_set_nss
 427 !      print *,"Processor",myrank," computed USCSC"
 428 #ifdef TIMING
 429       time01=MPI_Wtime()
 430 #endif
 431       call vec_and_deriv
 432 #ifdef TIMING
 433       time_vec=time_vec+MPI_Wtime()-time01
 434 #endif
 435 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 436       if (ipot.lt.6) then
 437 #ifdef SPLITELE
 438 !         print *,"after ipot if", ipot
 439          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 440              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 441              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 442              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 443 #else
 444          if (welec.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 #endif
 449 !            print *,"just befor eelec call"
 450             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 451 !         write (iout,*) "ELEC calc"
 452          else
 453             ees=0.0d0
 454             evdw1=0.0d0
 455             eel_loc=0.0d0
 456             eello_turn3=0.0d0
 457             eello_turn4=0.0d0
 458          endif
 459       else
 460 !        write (iout,*) "Soft-spheer ELEC potential"
 461         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 462          eello_turn4)
 463       endif
 464 !      print *,"Processor",myrank," computed UELEC"
 465 !
 466 ! Calculate excluded-volume interaction energy between peptide groups
 467 ! and side chains.
 468 !
 469 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 470
 471       if (ipot.lt.6) then
 472        if(wscp.gt.0d0) then
 473         call escp(evdw2,evdw2_14)
 474        else
 475         evdw2=0
 476         evdw2_14=0
 477        endif
 478       else
 479 !        write (iout,*) "Soft-sphere SCP potential"
 480         call escp_soft_sphere(evdw2,evdw2_14)
 481       endif
 482 !       write(iout,*) "in etotal before ebond",ipot
 483
 484 !
 485 ! Calculate the bond-stretching energy
 486 !
 487       call ebond(estr)
 488 !       print *,"EBOND",estr
 489 !       write(iout,*) "in etotal afer ebond",ipot
 490
 491 !
 492 ! Calculate the disulfide-bridge and other energy and the contributions
 493 ! from other distance constraints.
 494 !      print *,'Calling EHPB'
 495       call edis(ehpb)
 496 !elwrite(iout,*) "in etotal afer edis",ipot
 497 !      print *,'EHPB exitted succesfully.'
 498 !
 499 ! Calculate the virtual-bond-angle energy.
 500 !
 501       if (wang.gt.0d0) then
 502         call ebend(ebe,ethetacnstr)
 503       else
 504         ebe=0
 505         ethetacnstr=0
 506       endif
 507 !      print *,"Processor",myrank," computed UB"
 508 !
 509 ! Calculate the SC local energy.
 510 !
 511       call esc(escloc)
 512 !elwrite(iout,*) "in etotal afer esc",ipot
 513 !      print *,"Processor",myrank," computed USC"
 514 !
 515 ! Calculate the virtual-bond torsional energy.
 516 !
 517 !d    print *,'nterm=',nterm
 518       if (wtor.gt.0) then
 519        call etor(etors,edihcnstr)
 520       else
 521        etors=0
 522        edihcnstr=0
 523       endif
 524 !      print *,"Processor",myrank," computed Utor"
 525 !
 526 ! 6/23/01 Calculate double-torsional energy
 527 !
 528 !elwrite(iout,*) "in etotal",ipot
 529       if (wtor_d.gt.0) then
 530        call etor_d(etors_d)
 531       else
 532        etors_d=0
 533       endif
 534 !      print *,"Processor",myrank," computed Utord"
 535 !
 536 ! 21/5/07 Calculate local sicdechain correlation energy
 537 !
 538       if (wsccor.gt.0.0d0) then
 539         call eback_sc_corr(esccor)
 540       else
 541         esccor=0.0d0
 542       endif
 543 !      print *,"Processor",myrank," computed Usccorr"
 544 !
 545 ! 12/1/95 Multi-body terms
 546 !
 547       n_corr=0
 548       n_corr1=0
 549       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 550           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 551          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 552 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 553 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 554       else
 555          ecorr=0.0d0
 556          ecorr5=0.0d0
 557          ecorr6=0.0d0
 558          eturn6=0.0d0
 559       endif
 560 !elwrite(iout,*) "in etotal",ipot
 561       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 562          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 563 !d         write (iout,*) "multibody_hb ecorr",ecorr
 564       endif
 565 !elwrite(iout,*) "afeter  multibody hb"
 566
 567 !      print *,"Processor",myrank," computed Ucorr"
 568 !
 569 ! If performing constraint dynamics, call the constraint energy
 570 !  after the equilibration time
 571       if(usampl.and.totT.gt.eq_time) then
 572 !elwrite(iout,*) "afeter  multibody hb"
 573          call EconstrQ
 574 !elwrite(iout,*) "afeter  multibody hb"
 575          call Econstr_back
 576 !elwrite(iout,*) "afeter  multibody hb"
 577       else
 578          Uconst=0.0d0
 579          Uconst_back=0.0d0
 580       endif
 581       call flush(iout)
 582 !         write(iout,*) "after Econstr"
 583
 584       if (wliptran.gt.0) then
 585 !        print *,"PRZED WYWOLANIEM"
 586         call Eliptransfer(eliptran)
 587       else
 588        eliptran=0.0d0
 589       endif
 590       if (fg_rank.eq.0) then
 591       if (AFMlog.gt.0) then
 592         call AFMforce(Eafmforce)
 593       else if (selfguide.gt.0) then
 594         call AFMvel(Eafmforce)
 595       endif
 596       endif
 597       if (tubemode.eq.1) then
 598        call calctube(etube)
 599       else if (tubemode.eq.2) then
 600        call calctube2(etube)
 601       elseif (tubemode.eq.3) then
 602        call calcnano(etube)
 603       else
 604        etube=0.0d0
 605       endif
 606 !--------------------------------------------------------
 607 !      print *,"before",ees,evdw1,ecorr
 608       if (nres_molec(2).gt.0) then
 609       call ebond_nucl(estr_nucl)
 610       call ebend_nucl(ebe_nucl)
 611       call etor_nucl(etors_nucl)
 612       call esb_gb(evdwsb,eelsb)
 613       call epp_nucl_sub(evdwpp,eespp)
 614       call epsb(evdwpsb,eelpsb)
 615       call esb(esbloc)
 616       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 617       endif
 618       if (nfgtasks.gt.1) then
 619       if (fg_rank.eq.0) then
 620       call ecatcat(ecationcation)
 621       endif
 622       else
 623       call ecatcat(ecationcation)
 624       endif
 625       call ecat_prot(ecation_prot)
 626       if (nres_molec(2).gt.0) then
 627       call eprot_sc_base(escbase)
 628       call epep_sc_base(epepbase)
 629       call eprot_sc_phosphate(escpho)
 630       call eprot_pep_phosphate(epeppho)
 631       endif
 632 !      call ecatcat(ecationcation)
 633 !      print *,"after ebend", ebe_nucl
 634 #ifdef TIMING
 635       time_enecalc=time_enecalc+MPI_Wtime()-time00
 636 #endif
 637 !      print *,"Processor",myrank," computed Uconstr"
 638 #ifdef TIMING
 639       time00=MPI_Wtime()
 640 #endif
 641 !
 642 ! Sum the energies
 643 !
 644       energia(1)=evdw
 645 #ifdef SCP14
 646       energia(2)=evdw2-evdw2_14
 647       energia(18)=evdw2_14
 648 #else
 649       energia(2)=evdw2
 650       energia(18)=0.0d0
 651 #endif
 652 #ifdef SPLITELE
 653       energia(3)=ees
 654       energia(16)=evdw1
 655 #else
 656       energia(3)=ees+evdw1
 657       energia(16)=0.0d0
 658 #endif
 659       energia(4)=ecorr
 660       energia(5)=ecorr5
 661       energia(6)=ecorr6
 662       energia(7)=eel_loc
 663       energia(8)=eello_turn3
 664       energia(9)=eello_turn4
 665       energia(10)=eturn6
 666       energia(11)=ebe
 667       energia(12)=escloc
 668       energia(13)=etors
 669       energia(14)=etors_d
 670       energia(15)=ehpb
 671       energia(19)=edihcnstr
 672       energia(17)=estr
 673       energia(20)=Uconst+Uconst_back
 674       energia(21)=esccor
 675       energia(22)=eliptran
 676       energia(23)=Eafmforce
 677       energia(24)=ethetacnstr
 678       energia(25)=etube
 679 !---------------------------------------------------------------
 680       energia(26)=evdwpp
 681       energia(27)=eespp
 682       energia(28)=evdwpsb
 683       energia(29)=eelpsb
 684       energia(30)=evdwsb
 685       energia(31)=eelsb
 686       energia(32)=estr_nucl
 687       energia(33)=ebe_nucl
 688       energia(34)=esbloc
 689       energia(35)=etors_nucl
 690       energia(36)=etors_d_nucl
 691       energia(37)=ecorr_nucl
 692       energia(38)=ecorr3_nucl
 693 !----------------------------------------------------------------------
 694 !    Here are the energies showed per procesor if the are more processors
 695 !    per molecule then we sum it up in sum_energy subroutine
 696 !      print *," Processor",myrank," calls SUM_ENERGY"
 697       energia(41)=ecation_prot
 698       energia(42)=ecationcation
 699       energia(46)=escbase
 700       energia(47)=epepbase
 701       energia(48)=escpho
 702       energia(49)=epeppho
 703       call sum_energy(energia,.true.)
 704       if (dyn_ss) call dyn_set_nss
 705 !      print *," Processor",myrank," left SUM_ENERGY"
 706 #ifdef TIMING
 707       time_sumene=time_sumene+MPI_Wtime()-time00
 708 #endif
 709 !el        call enerprint(energia)
 710 !elwrite(iout,*)"finish etotal"
 711       return
 712       end subroutine etotal
 713 !-----------------------------------------------------------------------------
 714       subroutine sum_energy(energia,reduce)
 715 !      implicit real*8 (a-h,o-z)
 716 !      include 'DIMENSIONS'
 717 #ifndef ISNAN
 718       external proc_proc
 719 #ifdef WINPGI
 720 !MS$ATTRIBUTES C ::  proc_proc
 721 #endif
 722 #endif
 723 #ifdef MPI
 724       include "mpif.h"
 725 #endif
 726 !      include 'COMMON.SETUP'
 727 !      include 'COMMON.IOUNITS'
 728       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 729 !      include 'COMMON.FFIELD'
 730 !      include 'COMMON.DERIV'
 731 !      include 'COMMON.INTERACT'
 732 !      include 'COMMON.SBRIDGE'
 733 !      include 'COMMON.CHAIN'
 734 !      include 'COMMON.VAR'
 735 !      include 'COMMON.CONTROL'
 736 !      include 'COMMON.TIME1'
 737       logical :: reduce
 738       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 739       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 740       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 741         eliptran,etube, Eafmforce,ethetacnstr
 742       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 743                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 744                       ecorr3_nucl
 745       real(kind=8) :: ecation_prot,ecationcation
 746       real(kind=8) :: escbase,epepbase,escpho,epeppho
 747       integer :: i
 748 #ifdef MPI
 749       integer :: ierr
 750       real(kind=8) :: time00
 751       if (nfgtasks.gt.1 .and. reduce) then
 752
 753 #ifdef DEBUG
 754         write (iout,*) "energies before REDUCE"
 755         call enerprint(energia)
 756         call flush(iout)
 757 #endif
 758         do i=0,n_ene
 759           enebuff(i)=energia(i)
 760         enddo
 761         time00=MPI_Wtime()
 762         call MPI_Barrier(FG_COMM,IERR)
 763         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 764         time00=MPI_Wtime()
 765         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 766           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 767 #ifdef DEBUG
 768         write (iout,*) "energies after REDUCE"
 769         call enerprint(energia)
 770         call flush(iout)
 771 #endif
 772         time_Reduce=time_Reduce+MPI_Wtime()-time00
 773       endif
 774       if (fg_rank.eq.0) then
 775 #endif
 776       evdw=energia(1)
 777 #ifdef SCP14
 778       evdw2=energia(2)+energia(18)
 779       evdw2_14=energia(18)
 780 #else
 781       evdw2=energia(2)
 782 #endif
 783 #ifdef SPLITELE
 784       ees=energia(3)
 785       evdw1=energia(16)
 786 #else
 787       ees=energia(3)
 788       evdw1=0.0d0
 789 #endif
 790       ecorr=energia(4)
 791       ecorr5=energia(5)
 792       ecorr6=energia(6)
 793       eel_loc=energia(7)
 794       eello_turn3=energia(8)
 795       eello_turn4=energia(9)
 796       eturn6=energia(10)
 797       ebe=energia(11)
 798       escloc=energia(12)
 799       etors=energia(13)
 800       etors_d=energia(14)
 801       ehpb=energia(15)
 802       edihcnstr=energia(19)
 803       estr=energia(17)
 804       Uconst=energia(20)
 805       esccor=energia(21)
 806       eliptran=energia(22)
 807       Eafmforce=energia(23)
 808       ethetacnstr=energia(24)
 809       etube=energia(25)
 810       evdwpp=energia(26)
 811       eespp=energia(27)
 812       evdwpsb=energia(28)
 813       eelpsb=energia(29)
 814       evdwsb=energia(30)
 815       eelsb=energia(31)
 816       estr_nucl=energia(32)
 817       ebe_nucl=energia(33)
 818       esbloc=energia(34)
 819       etors_nucl=energia(35)
 820       etors_d_nucl=energia(36)
 821       ecorr_nucl=energia(37)
 822       ecorr3_nucl=energia(38)
 823       ecation_prot=energia(41)
 824       ecationcation=energia(42)
 825       escbase=energia(46)
 826       epepbase=energia(47)
 827       escpho=energia(48)
 828       epeppho=energia(49)
 829 !      energia(41)=ecation_prot
 830 !      energia(42)=ecationcation
 831
 832
 833 #ifdef SPLITELE
 834       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 835        +wang*ebe+wtor*etors+wscloc*escloc &
 836        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 837        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 838        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 839        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 840        +Eafmforce+ethetacnstr  &
 841        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 842        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 843        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 844        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 845        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 846        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 847 #else
 848       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 849        +wang*ebe+wtor*etors+wscloc*escloc &
 850        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 851        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 852        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 853        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 854        +Eafmforce+ethetacnstr &
 855        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 856        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 857        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 858        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 859        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 860        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 861 #endif
 862       energia(0)=etot
 863 ! detecting NaNQ
 864 #ifdef ISNAN
 865 #ifdef AIX
 866       if (isnan(etot).ne.0) energia(0)=1.0d+99
 867 #else
 868       if (isnan(etot)) energia(0)=1.0d+99
 869 #endif
 870 #else
 871       i=0
 872 #ifdef WINPGI
 873       idumm=proc_proc(etot,i)
 874 #else
 875       call proc_proc(etot,i)
 876 #endif
 877       if(i.eq.1)energia(0)=1.0d+99
 878 #endif
 879 #ifdef MPI
 880       endif
 881 #endif
 882 !      call enerprint(energia)
 883       call flush(iout)
 884       return
 885       end subroutine sum_energy
 886 !-----------------------------------------------------------------------------
 887       subroutine rescale_weights(t_bath)
 888 !      implicit real*8 (a-h,o-z)
 889 #ifdef MPI
 890       include 'mpif.h'
 891 #endif
 892 !      include 'DIMENSIONS'
 893 !      include 'COMMON.IOUNITS'
 894 !      include 'COMMON.FFIELD'
 895 !      include 'COMMON.SBRIDGE'
 896       real(kind=8) :: kfac=2.4d0
 897       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 898 !el local variables
 899       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 900       real(kind=8) :: T0=3.0d2
 901       integer :: ierror
 902 !      facT=temp0/t_bath
 903 !      facT=2*temp0/(t_bath+temp0)
 904       if (rescale_mode.eq.0) then
 905         facT(1)=1.0d0
 906         facT(2)=1.0d0
 907         facT(3)=1.0d0
 908         facT(4)=1.0d0
 909         facT(5)=1.0d0
 910         facT(6)=1.0d0
 911       else if (rescale_mode.eq.1) then
 912         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 913         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 914         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 915         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 916         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 917 #ifdef WHAM_RUN
 918 !#if defined(WHAM_RUN) || defined(CLUSTER)
 919 #if defined(FUNCTH)
 920 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 921         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 922 #elif defined(FUNCT)
 923         facT(6)=t_bath/T0
 924 #else
 925         facT(6)=1.0d0
 926 #endif
 927 #endif
 928       else if (rescale_mode.eq.2) then
 929         x=t_bath/temp0
 930         x2=x*x
 931         x3=x2*x
 932         x4=x3*x
 933         x5=x4*x
 934         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 935         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 936         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 937         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 938         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 939 #ifdef WHAM_RUN
 940 !#if defined(WHAM_RUN) || defined(CLUSTER)
 941 #if defined(FUNCTH)
 942         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 943 #elif defined(FUNCT)
 944         facT(6)=t_bath/T0
 945 #else
 946         facT(6)=1.0d0
 947 #endif
 948 #endif
 949       else
 950         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 951         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 952 #ifdef MPI
 953        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 954 #endif
 955        stop 555
 956       endif
 957       welec=weights(3)*fact(1)
 958       wcorr=weights(4)*fact(3)
 959       wcorr5=weights(5)*fact(4)
 960       wcorr6=weights(6)*fact(5)
 961       wel_loc=weights(7)*fact(2)
 962       wturn3=weights(8)*fact(2)
 963       wturn4=weights(9)*fact(3)
 964       wturn6=weights(10)*fact(5)
 965       wtor=weights(13)*fact(1)
 966       wtor_d=weights(14)*fact(2)
 967       wsccor=weights(21)*fact(1)
 968
 969       return
 970       end subroutine rescale_weights
 971 !-----------------------------------------------------------------------------
 972       subroutine enerprint(energia)
 973 !      implicit real*8 (a-h,o-z)
 974 !      include 'DIMENSIONS'
 975 !      include 'COMMON.IOUNITS'
 976 !      include 'COMMON.FFIELD'
 977 !      include 'COMMON.SBRIDGE'
 978 !      include 'COMMON.MD'
 979       real(kind=8) :: energia(0:n_ene)
 980 !el local variables
 981       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 982       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 983       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 984        etube,ethetacnstr,Eafmforce
 985       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 986                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 987                       ecorr3_nucl
 988       real(kind=8) :: ecation_prot,ecationcation
 989       real(kind=8) :: escbase,epepbase,escpho,epeppho
 990
 991       etot=energia(0)
 992       evdw=energia(1)
 993       evdw2=energia(2)
 994 #ifdef SCP14
 995       evdw2=energia(2)+energia(18)
 996 #else
 997       evdw2=energia(2)
 998 #endif
 999       ees=energia(3)
1000 #ifdef SPLITELE
1001       evdw1=energia(16)
1002 #endif
1003       ecorr=energia(4)
1004       ecorr5=energia(5)
1005       ecorr6=energia(6)
1006       eel_loc=energia(7)
1007       eello_turn3=energia(8)
1008       eello_turn4=energia(9)
1009       eello_turn6=energia(10)
1010       ebe=energia(11)
1011       escloc=energia(12)
1012       etors=energia(13)
1013       etors_d=energia(14)
1014       ehpb=energia(15)
1015       edihcnstr=energia(19)
1016       estr=energia(17)
1017       Uconst=energia(20)
1018       esccor=energia(21)
1019       eliptran=energia(22)
1020       Eafmforce=energia(23)
1021       ethetacnstr=energia(24)
1022       etube=energia(25)
1023       evdwpp=energia(26)
1024       eespp=energia(27)
1025       evdwpsb=energia(28)
1026       eelpsb=energia(29)
1027       evdwsb=energia(30)
1028       eelsb=energia(31)
1029       estr_nucl=energia(32)
1030       ebe_nucl=energia(33)
1031       esbloc=energia(34)
1032       etors_nucl=energia(35)
1033       etors_d_nucl=energia(36)
1034       ecorr_nucl=energia(37)
1035       ecorr3_nucl=energia(38)
1036       ecation_prot=energia(41)
1037       ecationcation=energia(42)
1038       escbase=energia(46)
1039       epepbase=energia(47)
1040       escpho=energia(48)
1041       epeppho=energia(49)
1042 #ifdef SPLITELE
1043       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1044         estr,wbond,ebe,wang,&
1045         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1046         ecorr,wcorr,&
1047         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1048         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1049         edihcnstr,ethetacnstr,ebr*nss,&
1050         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1051         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1052         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1053         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1054         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1055         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1056         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1057         etot
1058    10 format (/'Virtual-chain energies:'// &
1059        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1060        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1061        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1062        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1063        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1064        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1065        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1066        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1067        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1068        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1069        ' (SS bridges & dist. cnstr.)'/ &
1070        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1071        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1072        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1073        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1074        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1075        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1076        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1077        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1078        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1079        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1080        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1081        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1082        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1083        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1084        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1085        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1086        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1087        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1088        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1089        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1090        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1091        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1092        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1093        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1094        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1095        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1096        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1097        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1098        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1099        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1100        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1101        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1102        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1103        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1104        'ETOT=  ',1pE16.6,' (total)')
1105 #else
1106       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1107         estr,wbond,ebe,wang,&
1108         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1109         ecorr,wcorr,&
1110         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1111         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1112         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1113         etube,wtube, &
1114         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1115         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1116         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1117         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1118         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1119         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1120         etot
1121    10 format (/'Virtual-chain energies:'// &
1122        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1123        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1124        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1125        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1126        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1127        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1128        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1129        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1130        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1131        ' (SS bridges & dist. cnstr.)'/ &
1132        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1133        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1134        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1135        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1136        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1137        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1138        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1139        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1140        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1141        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1142        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1143        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1144        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1145        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1146        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1147        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1148        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1149        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1150        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1151        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1152        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1153        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1154        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1155        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1156        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1157        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1158        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1159        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1160        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1161        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1162        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1163        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1164        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1165        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1166        'ETOT=  ',1pE16.6,' (total)')
1167 #endif
1168       return
1169       end subroutine enerprint
1170 !-----------------------------------------------------------------------------
1171       subroutine elj(evdw)
1172 !
1173 ! This subroutine calculates the interaction energy of nonbonded side chains
1174 ! assuming the LJ potential of interaction.
1175 !
1176 !      implicit real*8 (a-h,o-z)
1177 !      include 'DIMENSIONS'
1178       real(kind=8),parameter :: accur=1.0d-10
1179 !      include 'COMMON.GEO'
1180 !      include 'COMMON.VAR'
1181 !      include 'COMMON.LOCAL'
1182 !      include 'COMMON.CHAIN'
1183 !      include 'COMMON.DERIV'
1184 !      include 'COMMON.INTERACT'
1185 !      include 'COMMON.TORSION'
1186 !      include 'COMMON.SBRIDGE'
1187 !      include 'COMMON.NAMES'
1188 !      include 'COMMON.IOUNITS'
1189 !      include 'COMMON.CONTACTS'
1190       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1191       integer :: num_conti
1192 !el local variables
1193       integer :: i,itypi,iint,j,itypi1,itypj,k
1194       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1195       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1196       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1197
1198 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1199       evdw=0.0D0
1200 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1201 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1202 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1203 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1204
1205       do i=iatsc_s,iatsc_e
1206         itypi=iabs(itype(i,1))
1207         if (itypi.eq.ntyp1) cycle
1208         itypi1=iabs(itype(i+1,1))
1209         xi=c(1,nres+i)
1210         yi=c(2,nres+i)
1211         zi=c(3,nres+i)
1212 ! Change 12/1/95
1213         num_conti=0
1214 !
1215 ! Calculate SC interaction energy.
1216 !
1217         do iint=1,nint_gr(i)
1218 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1219 !d   &                  'iend=',iend(i,iint)
1220           do j=istart(i,iint),iend(i,iint)
1221             itypj=iabs(itype(j,1))
1222             if (itypj.eq.ntyp1) cycle
1223             xj=c(1,nres+j)-xi
1224             yj=c(2,nres+j)-yi
1225             zj=c(3,nres+j)-zi
1226 ! Change 12/1/95 to calculate four-body interactions
1227             rij=xj*xj+yj*yj+zj*zj
1228             rrij=1.0D0/rij
1229 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1230             eps0ij=eps(itypi,itypj)
1231             fac=rrij**expon2
1232             e1=fac*fac*aa_aq(itypi,itypj)
1233             e2=fac*bb_aq(itypi,itypj)
1234             evdwij=e1+e2
1235 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1236 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1237 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1238 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1239 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1240 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1241             evdw=evdw+evdwij
1242 !
1243 ! Calculate the components of the gradient in DC and X
1244 !
1245             fac=-rrij*(e1+evdwij)
1246             gg(1)=xj*fac
1247             gg(2)=yj*fac
1248             gg(3)=zj*fac
1249             do k=1,3
1250               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1251               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1252               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1253               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1254             enddo
1255 !grad            do k=i,j-1
1256 !grad              do l=1,3
1257 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1258 !grad              enddo
1259 !grad            enddo
1260 !
1261 ! 12/1/95, revised on 5/20/97
1262 !
1263 ! Calculate the contact function. The ith column of the array JCONT will
1264 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1265 ! greater than I). The arrays FACONT and GACONT will contain the values of
1266 ! the contact function and its derivative.
1267 !
1268 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1269 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1270 ! Uncomment next line, if the correlation interactions are contact function only
1271             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1272               rij=dsqrt(rij)
1273               sigij=sigma(itypi,itypj)
1274               r0ij=rs0(itypi,itypj)
1275 !
1276 ! Check whether the SC's are not too far to make a contact.
1277 !
1278               rcut=1.5d0*r0ij
1279               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1280 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1281 !
1282               if (fcont.gt.0.0D0) then
1283 ! If the SC-SC distance if close to sigma, apply spline.
1284 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1285 !Adam &             fcont1,fprimcont1)
1286 !Adam           fcont1=1.0d0-fcont1
1287 !Adam           if (fcont1.gt.0.0d0) then
1288 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1289 !Adam             fcont=fcont*fcont1
1290 !Adam           endif
1291 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1292 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1293 !ga             do k=1,3
1294 !ga               gg(k)=gg(k)*eps0ij
1295 !ga             enddo
1296 !ga             eps0ij=-evdwij*eps0ij
1297 ! Uncomment for AL's type of SC correlation interactions.
1298 !adam           eps0ij=-evdwij
1299                 num_conti=num_conti+1
1300                 jcont(num_conti,i)=j
1301                 facont(num_conti,i)=fcont*eps0ij
1302                 fprimcont=eps0ij*fprimcont/rij
1303                 fcont=expon*fcont
1304 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1305 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1306 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1307 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1308                 gacont(1,num_conti,i)=-fprimcont*xj
1309                 gacont(2,num_conti,i)=-fprimcont*yj
1310                 gacont(3,num_conti,i)=-fprimcont*zj
1311 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1312 !d              write (iout,'(2i3,3f10.5)')
1313 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1314               endif
1315             endif
1316           enddo      ! j
1317         enddo        ! iint
1318 ! Change 12/1/95
1319         num_cont(i)=num_conti
1320       enddo          ! i
1321       do i=1,nct
1322         do j=1,3
1323           gvdwc(j,i)=expon*gvdwc(j,i)
1324           gvdwx(j,i)=expon*gvdwx(j,i)
1325         enddo
1326       enddo
1327 !******************************************************************************
1328 !
1329 !                              N O T E !!!
1330 !
1331 ! To save time, the factor of EXPON has been extracted from ALL components
1332 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1333 ! use!
1334 !
1335 !******************************************************************************
1336       return
1337       end subroutine elj
1338 !-----------------------------------------------------------------------------
1339       subroutine eljk(evdw)
1340 !
1341 ! This subroutine calculates the interaction energy of nonbonded side chains
1342 ! assuming the LJK potential of interaction.
1343 !
1344 !      implicit real*8 (a-h,o-z)
1345 !      include 'DIMENSIONS'
1346 !      include 'COMMON.GEO'
1347 !      include 'COMMON.VAR'
1348 !      include 'COMMON.LOCAL'
1349 !      include 'COMMON.CHAIN'
1350 !      include 'COMMON.DERIV'
1351 !      include 'COMMON.INTERACT'
1352 !      include 'COMMON.IOUNITS'
1353 !      include 'COMMON.NAMES'
1354       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1355       logical :: scheck
1356 !el local variables
1357       integer :: i,iint,j,itypi,itypi1,k,itypj
1358       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1359       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1360
1361 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1362       evdw=0.0D0
1363       do i=iatsc_s,iatsc_e
1364         itypi=iabs(itype(i,1))
1365         if (itypi.eq.ntyp1) cycle
1366         itypi1=iabs(itype(i+1,1))
1367         xi=c(1,nres+i)
1368         yi=c(2,nres+i)
1369         zi=c(3,nres+i)
1370 !
1371 ! Calculate SC interaction energy.
1372 !
1373         do iint=1,nint_gr(i)
1374           do j=istart(i,iint),iend(i,iint)
1375             itypj=iabs(itype(j,1))
1376             if (itypj.eq.ntyp1) cycle
1377             xj=c(1,nres+j)-xi
1378             yj=c(2,nres+j)-yi
1379             zj=c(3,nres+j)-zi
1380             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1381             fac_augm=rrij**expon
1382             e_augm=augm(itypi,itypj)*fac_augm
1383             r_inv_ij=dsqrt(rrij)
1384             rij=1.0D0/r_inv_ij
1385             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1386             fac=r_shift_inv**expon
1387             e1=fac*fac*aa_aq(itypi,itypj)
1388             e2=fac*bb_aq(itypi,itypj)
1389             evdwij=e_augm+e1+e2
1390 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1391 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1392 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1393 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1394 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1395 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1396 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1397             evdw=evdw+evdwij
1398 !
1399 ! Calculate the components of the gradient in DC and X
1400 !
1401             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1402             gg(1)=xj*fac
1403             gg(2)=yj*fac
1404             gg(3)=zj*fac
1405             do k=1,3
1406               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1407               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1408               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1409               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1410             enddo
1411 !grad            do k=i,j-1
1412 !grad              do l=1,3
1413 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1414 !grad              enddo
1415 !grad            enddo
1416           enddo      ! j
1417         enddo        ! iint
1418       enddo          ! i
1419       do i=1,nct
1420         do j=1,3
1421           gvdwc(j,i)=expon*gvdwc(j,i)
1422           gvdwx(j,i)=expon*gvdwx(j,i)
1423         enddo
1424       enddo
1425       return
1426       end subroutine eljk
1427 !-----------------------------------------------------------------------------
1428       subroutine ebp(evdw)
1429 !
1430 ! This subroutine calculates the interaction energy of nonbonded side chains
1431 ! assuming the Berne-Pechukas potential of interaction.
1432 !
1433       use comm_srutu
1434       use calc_data
1435 !      implicit real*8 (a-h,o-z)
1436 !      include 'DIMENSIONS'
1437 !      include 'COMMON.GEO'
1438 !      include 'COMMON.VAR'
1439 !      include 'COMMON.LOCAL'
1440 !      include 'COMMON.CHAIN'
1441 !      include 'COMMON.DERIV'
1442 !      include 'COMMON.NAMES'
1443 !      include 'COMMON.INTERACT'
1444 !      include 'COMMON.IOUNITS'
1445 !      include 'COMMON.CALC'
1446       use comm_srutu
1447 !el      integer :: icall
1448 !el      common /srutu/ icall
1449 !     double precision rrsave(maxdim)
1450       logical :: lprn
1451 !el local variables
1452       integer :: iint,itypi,itypi1,itypj
1453       real(kind=8) :: rrij,xi,yi,zi
1454       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1455
1456 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1457       evdw=0.0D0
1458 !     if (icall.eq.0) then
1459 !       lprn=.true.
1460 !     else
1461         lprn=.false.
1462 !     endif
1463 !el      ind=0
1464       do i=iatsc_s,iatsc_e
1465         itypi=iabs(itype(i,1))
1466         if (itypi.eq.ntyp1) cycle
1467         itypi1=iabs(itype(i+1,1))
1468         xi=c(1,nres+i)
1469         yi=c(2,nres+i)
1470         zi=c(3,nres+i)
1471         dxi=dc_norm(1,nres+i)
1472         dyi=dc_norm(2,nres+i)
1473         dzi=dc_norm(3,nres+i)
1474 !        dsci_inv=dsc_inv(itypi)
1475         dsci_inv=vbld_inv(i+nres)
1476 !
1477 ! Calculate SC interaction energy.
1478 !
1479         do iint=1,nint_gr(i)
1480           do j=istart(i,iint),iend(i,iint)
1481 !el            ind=ind+1
1482             itypj=iabs(itype(j,1))
1483             if (itypj.eq.ntyp1) cycle
1484 !            dscj_inv=dsc_inv(itypj)
1485             dscj_inv=vbld_inv(j+nres)
1486             chi1=chi(itypi,itypj)
1487             chi2=chi(itypj,itypi)
1488             chi12=chi1*chi2
1489             chip1=chip(itypi)
1490             chip2=chip(itypj)
1491             chip12=chip1*chip2
1492             alf1=alp(itypi)
1493             alf2=alp(itypj)
1494             alf12=0.5D0*(alf1+alf2)
1495 ! For diagnostics only!!!
1496 !           chi1=0.0D0
1497 !           chi2=0.0D0
1498 !           chi12=0.0D0
1499 !           chip1=0.0D0
1500 !           chip2=0.0D0
1501 !           chip12=0.0D0
1502 !           alf1=0.0D0
1503 !           alf2=0.0D0
1504 !           alf12=0.0D0
1505             xj=c(1,nres+j)-xi
1506             yj=c(2,nres+j)-yi
1507             zj=c(3,nres+j)-zi
1508             dxj=dc_norm(1,nres+j)
1509             dyj=dc_norm(2,nres+j)
1510             dzj=dc_norm(3,nres+j)
1511             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1512 !d          if (icall.eq.0) then
1513 !d            rrsave(ind)=rrij
1514 !d          else
1515 !d            rrij=rrsave(ind)
1516 !d          endif
1517             rij=dsqrt(rrij)
1518 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1519             call sc_angular
1520 ! Calculate whole angle-dependent part of epsilon and contributions
1521 ! to its derivatives
1522             fac=(rrij*sigsq)**expon2
1523             e1=fac*fac*aa_aq(itypi,itypj)
1524             e2=fac*bb_aq(itypi,itypj)
1525             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1526             eps2der=evdwij*eps3rt
1527             eps3der=evdwij*eps2rt
1528             evdwij=evdwij*eps2rt*eps3rt
1529             evdw=evdw+evdwij
1530             if (lprn) then
1531             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1532             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1533 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1534 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1535 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1536 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1537 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1538 !d     &        evdwij
1539             endif
1540 ! Calculate gradient components.
1541             e1=e1*eps1*eps2rt**2*eps3rt**2
1542             fac=-expon*(e1+evdwij)
1543             sigder=fac/sigsq
1544             fac=rrij*fac
1545 ! Calculate radial part of the gradient
1546             gg(1)=xj*fac
1547             gg(2)=yj*fac
1548             gg(3)=zj*fac
1549 ! Calculate the angular part of the gradient and sum add the contributions
1550 ! to the appropriate components of the Cartesian gradient.
1551             call sc_grad
1552           enddo      ! j
1553         enddo        ! iint
1554       enddo          ! i
1555 !     stop
1556       return
1557       end subroutine ebp
1558 !-----------------------------------------------------------------------------
1559       subroutine egb(evdw)
1560 !
1561 ! This subroutine calculates the interaction energy of nonbonded side chains
1562 ! assuming the Gay-Berne potential of interaction.
1563 !
1564       use calc_data
1565 !      implicit real*8 (a-h,o-z)
1566 !      include 'DIMENSIONS'
1567 !      include 'COMMON.GEO'
1568 !      include 'COMMON.VAR'
1569 !      include 'COMMON.LOCAL'
1570 !      include 'COMMON.CHAIN'
1571 !      include 'COMMON.DERIV'
1572 !      include 'COMMON.NAMES'
1573 !      include 'COMMON.INTERACT'
1574 !      include 'COMMON.IOUNITS'
1575 !      include 'COMMON.CALC'
1576 !      include 'COMMON.CONTROL'
1577 !      include 'COMMON.SBRIDGE'
1578       logical :: lprn
1579 !el local variables
1580       integer :: iint,itypi,itypi1,itypj,subchap
1581       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1582       real(kind=8) :: evdw,sig0ij
1583       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1584                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1585                     sslipi,sslipj,faclip
1586       integer :: ii
1587       real(kind=8) :: fracinbuf
1588
1589 !cccc      energy_dec=.false.
1590 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1591       evdw=0.0D0
1592       lprn=.false.
1593 !     if (icall.eq.0) lprn=.false.
1594 !el      ind=0
1595       do i=iatsc_s,iatsc_e
1596 !C        print *,"I am in EVDW",i
1597         itypi=iabs(itype(i,1))
1598 !        if (i.ne.47) cycle
1599         if (itypi.eq.ntyp1) cycle
1600         itypi1=iabs(itype(i+1,1))
1601         xi=c(1,nres+i)
1602         yi=c(2,nres+i)
1603         zi=c(3,nres+i)
1604           xi=dmod(xi,boxxsize)
1605           if (xi.lt.0) xi=xi+boxxsize
1606           yi=dmod(yi,boxysize)
1607           if (yi.lt.0) yi=yi+boxysize
1608           zi=dmod(zi,boxzsize)
1609           if (zi.lt.0) zi=zi+boxzsize
1610
1611        if ((zi.gt.bordlipbot)  &
1612         .and.(zi.lt.bordliptop)) then
1613 !C the energy transfer exist
1614         if (zi.lt.buflipbot) then
1615 !C what fraction I am in
1616          fracinbuf=1.0d0-  &
1617               ((zi-bordlipbot)/lipbufthick)
1618 !C lipbufthick is thickenes of lipid buffore
1619          sslipi=sscalelip(fracinbuf)
1620          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1621         elseif (zi.gt.bufliptop) then
1622          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1623          sslipi=sscalelip(fracinbuf)
1624          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1625         else
1626          sslipi=1.0d0
1627          ssgradlipi=0.0
1628         endif
1629        else
1630          sslipi=0.0d0
1631          ssgradlipi=0.0
1632        endif
1633 !       print *, sslipi,ssgradlipi
1634         dxi=dc_norm(1,nres+i)
1635         dyi=dc_norm(2,nres+i)
1636         dzi=dc_norm(3,nres+i)
1637 !        dsci_inv=dsc_inv(itypi)
1638         dsci_inv=vbld_inv(i+nres)
1639 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1640 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1641 !
1642 ! Calculate SC interaction energy.
1643 !
1644         do iint=1,nint_gr(i)
1645           do j=istart(i,iint),iend(i,iint)
1646             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1647               call dyn_ssbond_ene(i,j,evdwij)
1648               evdw=evdw+evdwij
1649               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1650                               'evdw',i,j,evdwij,' ss'
1651 !              if (energy_dec) write (iout,*) &
1652 !                              'evdw',i,j,evdwij,' ss'
1653              do k=j+1,iend(i,iint)
1654 !C search over all next residues
1655               if (dyn_ss_mask(k)) then
1656 !C check if they are cysteins
1657 !C              write(iout,*) 'k=',k
1658
1659 !c              write(iout,*) "PRZED TRI", evdwij
1660 !               evdwij_przed_tri=evdwij
1661               call triple_ssbond_ene(i,j,k,evdwij)
1662 !c               if(evdwij_przed_tri.ne.evdwij) then
1663 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1664 !c               endif
1665
1666 !c              write(iout,*) "PO TRI", evdwij
1667 !C call the energy function that removes the artifical triple disulfide
1668 !C bond the soubroutine is located in ssMD.F
1669               evdw=evdw+evdwij
1670               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1671                             'evdw',i,j,evdwij,'tss'
1672               endif!dyn_ss_mask(k)
1673              enddo! k
1674             ELSE
1675 !el            ind=ind+1
1676             itypj=iabs(itype(j,1))
1677             if (itypj.eq.ntyp1) cycle
1678 !             if (j.ne.78) cycle
1679 !            dscj_inv=dsc_inv(itypj)
1680             dscj_inv=vbld_inv(j+nres)
1681 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1682 !              1.0d0/vbld(j+nres) !d
1683 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1684             sig0ij=sigma(itypi,itypj)
1685             chi1=chi(itypi,itypj)
1686             chi2=chi(itypj,itypi)
1687             chi12=chi1*chi2
1688             chip1=chip(itypi)
1689             chip2=chip(itypj)
1690             chip12=chip1*chip2
1691             alf1=alp(itypi)
1692             alf2=alp(itypj)
1693             alf12=0.5D0*(alf1+alf2)
1694 ! For diagnostics only!!!
1695 !           chi1=0.0D0
1696 !           chi2=0.0D0
1697 !           chi12=0.0D0
1698 !           chip1=0.0D0
1699 !           chip2=0.0D0
1700 !           chip12=0.0D0
1701 !           alf1=0.0D0
1702 !           alf2=0.0D0
1703 !           alf12=0.0D0
1704            xj=c(1,nres+j)
1705            yj=c(2,nres+j)
1706            zj=c(3,nres+j)
1707           xj=dmod(xj,boxxsize)
1708           if (xj.lt.0) xj=xj+boxxsize
1709           yj=dmod(yj,boxysize)
1710           if (yj.lt.0) yj=yj+boxysize
1711           zj=dmod(zj,boxzsize)
1712           if (zj.lt.0) zj=zj+boxzsize
1713 !          print *,"tu",xi,yi,zi,xj,yj,zj
1714 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1715 ! this fragment set correct epsilon for lipid phase
1716        if ((zj.gt.bordlipbot)  &
1717        .and.(zj.lt.bordliptop)) then
1718 !C the energy transfer exist
1719         if (zj.lt.buflipbot) then
1720 !C what fraction I am in
1721          fracinbuf=1.0d0-     &
1722              ((zj-bordlipbot)/lipbufthick)
1723 !C lipbufthick is thickenes of lipid buffore
1724          sslipj=sscalelip(fracinbuf)
1725          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1726         elseif (zj.gt.bufliptop) then
1727          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1728          sslipj=sscalelip(fracinbuf)
1729          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1730         else
1731          sslipj=1.0d0
1732          ssgradlipj=0.0
1733         endif
1734        else
1735          sslipj=0.0d0
1736          ssgradlipj=0.0
1737        endif
1738       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1739        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1740       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1741        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1742 !------------------------------------------------
1743       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1744       xj_safe=xj
1745       yj_safe=yj
1746       zj_safe=zj
1747       subchap=0
1748       do xshift=-1,1
1749       do yshift=-1,1
1750       do zshift=-1,1
1751           xj=xj_safe+xshift*boxxsize
1752           yj=yj_safe+yshift*boxysize
1753           zj=zj_safe+zshift*boxzsize
1754           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1755           if(dist_temp.lt.dist_init) then
1756             dist_init=dist_temp
1757             xj_temp=xj
1758             yj_temp=yj
1759             zj_temp=zj
1760             subchap=1
1761           endif
1762        enddo
1763        enddo
1764        enddo
1765        if (subchap.eq.1) then
1766           xj=xj_temp-xi
1767           yj=yj_temp-yi
1768           zj=zj_temp-zi
1769        else
1770           xj=xj_safe-xi
1771           yj=yj_safe-yi
1772           zj=zj_safe-zi
1773        endif
1774             dxj=dc_norm(1,nres+j)
1775             dyj=dc_norm(2,nres+j)
1776             dzj=dc_norm(3,nres+j)
1777 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1778 !            write (iout,*) "j",j," dc_norm",& !d
1779 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1780 !          write(iout,*)"rrij ",rrij
1781 !          write(iout,*)"xj yj zj ", xj, yj, zj
1782 !          write(iout,*)"xi yi zi ", xi, yi, zi
1783 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1784             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1785             rij=dsqrt(rrij)
1786             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1787             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1788 !            print *,sss_ele_cut,sss_ele_grad,&
1789 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1790             if (sss_ele_cut.le.0.0) cycle
1791 ! Calculate angle-dependent terms of energy and contributions to their
1792 ! derivatives.
1793             call sc_angular
1794             sigsq=1.0D0/sigsq
1795             sig=sig0ij*dsqrt(sigsq)
1796             rij_shift=1.0D0/rij-sig+sig0ij
1797 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1798 !            "sig0ij",sig0ij
1799 ! for diagnostics; uncomment
1800 !            rij_shift=1.2*sig0ij
1801 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1802             if (rij_shift.le.0.0D0) then
1803               evdw=1.0D20
1804 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1805 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1806 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1807               return
1808             endif
1809             sigder=-sig*sigsq
1810 !---------------------------------------------------------------
1811             rij_shift=1.0D0/rij_shift
1812             fac=rij_shift**expon
1813             faclip=fac
1814             e1=fac*fac*aa!(itypi,itypj)
1815             e2=fac*bb!(itypi,itypj)
1816             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1817             eps2der=evdwij*eps3rt
1818             eps3der=evdwij*eps2rt
1819 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1820 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1821 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1822             evdwij=evdwij*eps2rt*eps3rt
1823             evdw=evdw+evdwij*sss_ele_cut
1824             if (lprn) then
1825             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1826             epsi=bb**2/aa!(itypi,itypj)
1827             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1828               restyp(itypi,1),i,restyp(itypj,1),j, &
1829               epsi,sigm,chi1,chi2,chip1,chip2, &
1830               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1831               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1832               evdwij
1833             endif
1834
1835             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1836                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1837 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1838 !            if (energy_dec) write (iout,*) &
1839 !                             'evdw',i,j,evdwij
1840 !                       print *,"ZALAMKA", evdw
1841
1842 ! Calculate gradient components.
1843             e1=e1*eps1*eps2rt**2*eps3rt**2
1844             fac=-expon*(e1+evdwij)*rij_shift
1845             sigder=fac*sigder
1846             fac=rij*fac
1847 !            print *,'before fac',fac,rij,evdwij
1848             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1849             /sigma(itypi,itypj)*rij
1850 !            print *,'grad part scale',fac,   &
1851 !             evdwij*sss_ele_grad/sss_ele_cut &
1852 !            /sigma(itypi,itypj)*rij
1853 !            fac=0.0d0
1854 ! Calculate the radial part of the gradient
1855             gg(1)=xj*fac
1856             gg(2)=yj*fac
1857             gg(3)=zj*fac
1858 !C Calculate the radial part of the gradient
1859             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1860        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1861         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1862        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1863             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1864             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1865
1866 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1867 ! Calculate angular part of the gradient.
1868             call sc_grad
1869             ENDIF    ! dyn_ss
1870           enddo      ! j
1871         enddo        ! iint
1872       enddo          ! i
1873 !       print *,"ZALAMKA", evdw
1874 !      write (iout,*) "Number of loop steps in EGB:",ind
1875 !ccc      energy_dec=.false.
1876       return
1877       end subroutine egb
1878 !-----------------------------------------------------------------------------
1879       subroutine egbv(evdw)
1880 !
1881 ! This subroutine calculates the interaction energy of nonbonded side chains
1882 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1883 !
1884       use comm_srutu
1885       use calc_data
1886 !      implicit real*8 (a-h,o-z)
1887 !      include 'DIMENSIONS'
1888 !      include 'COMMON.GEO'
1889 !      include 'COMMON.VAR'
1890 !      include 'COMMON.LOCAL'
1891 !      include 'COMMON.CHAIN'
1892 !      include 'COMMON.DERIV'
1893 !      include 'COMMON.NAMES'
1894 !      include 'COMMON.INTERACT'
1895 !      include 'COMMON.IOUNITS'
1896 !      include 'COMMON.CALC'
1897       use comm_srutu
1898 !el      integer :: icall
1899 !el      common /srutu/ icall
1900       logical :: lprn
1901 !el local variables
1902       integer :: iint,itypi,itypi1,itypj
1903       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1904       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1905
1906 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1907       evdw=0.0D0
1908       lprn=.false.
1909 !     if (icall.eq.0) lprn=.true.
1910 !el      ind=0
1911       do i=iatsc_s,iatsc_e
1912         itypi=iabs(itype(i,1))
1913         if (itypi.eq.ntyp1) cycle
1914         itypi1=iabs(itype(i+1,1))
1915         xi=c(1,nres+i)
1916         yi=c(2,nres+i)
1917         zi=c(3,nres+i)
1918         dxi=dc_norm(1,nres+i)
1919         dyi=dc_norm(2,nres+i)
1920         dzi=dc_norm(3,nres+i)
1921 !        dsci_inv=dsc_inv(itypi)
1922         dsci_inv=vbld_inv(i+nres)
1923 !
1924 ! Calculate SC interaction energy.
1925 !
1926         do iint=1,nint_gr(i)
1927           do j=istart(i,iint),iend(i,iint)
1928 !el            ind=ind+1
1929             itypj=iabs(itype(j,1))
1930             if (itypj.eq.ntyp1) cycle
1931 !            dscj_inv=dsc_inv(itypj)
1932             dscj_inv=vbld_inv(j+nres)
1933             sig0ij=sigma(itypi,itypj)
1934             r0ij=r0(itypi,itypj)
1935             chi1=chi(itypi,itypj)
1936             chi2=chi(itypj,itypi)
1937             chi12=chi1*chi2
1938             chip1=chip(itypi)
1939             chip2=chip(itypj)
1940             chip12=chip1*chip2
1941             alf1=alp(itypi)
1942             alf2=alp(itypj)
1943             alf12=0.5D0*(alf1+alf2)
1944 ! For diagnostics only!!!
1945 !           chi1=0.0D0
1946 !           chi2=0.0D0
1947 !           chi12=0.0D0
1948 !           chip1=0.0D0
1949 !           chip2=0.0D0
1950 !           chip12=0.0D0
1951 !           alf1=0.0D0
1952 !           alf2=0.0D0
1953 !           alf12=0.0D0
1954             xj=c(1,nres+j)-xi
1955             yj=c(2,nres+j)-yi
1956             zj=c(3,nres+j)-zi
1957             dxj=dc_norm(1,nres+j)
1958             dyj=dc_norm(2,nres+j)
1959             dzj=dc_norm(3,nres+j)
1960             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1961             rij=dsqrt(rrij)
1962 ! Calculate angle-dependent terms of energy and contributions to their
1963 ! derivatives.
1964             call sc_angular
1965             sigsq=1.0D0/sigsq
1966             sig=sig0ij*dsqrt(sigsq)
1967             rij_shift=1.0D0/rij-sig+r0ij
1968 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1969             if (rij_shift.le.0.0D0) then
1970               evdw=1.0D20
1971               return
1972             endif
1973             sigder=-sig*sigsq
1974 !---------------------------------------------------------------
1975             rij_shift=1.0D0/rij_shift
1976             fac=rij_shift**expon
1977             e1=fac*fac*aa_aq(itypi,itypj)
1978             e2=fac*bb_aq(itypi,itypj)
1979             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1980             eps2der=evdwij*eps3rt
1981             eps3der=evdwij*eps2rt
1982             fac_augm=rrij**expon
1983             e_augm=augm(itypi,itypj)*fac_augm
1984             evdwij=evdwij*eps2rt*eps3rt
1985             evdw=evdw+evdwij+e_augm
1986             if (lprn) then
1987             sigm=dabs(aa_aq(itypi,itypj)/&
1988             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1989             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1990             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1991               restyp(itypi,1),i,restyp(itypj,1),j,&
1992               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1993               chi1,chi2,chip1,chip2,&
1994               eps1,eps2rt**2,eps3rt**2,&
1995               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1996               evdwij+e_augm
1997             endif
1998 ! Calculate gradient components.
1999             e1=e1*eps1*eps2rt**2*eps3rt**2
2000             fac=-expon*(e1+evdwij)*rij_shift
2001             sigder=fac*sigder
2002             fac=rij*fac-2*expon*rrij*e_augm
2003 ! Calculate the radial part of the gradient
2004             gg(1)=xj*fac
2005             gg(2)=yj*fac
2006             gg(3)=zj*fac
2007 ! Calculate angular part of the gradient.
2008             call sc_grad
2009           enddo      ! j
2010         enddo        ! iint
2011       enddo          ! i
2012       end subroutine egbv
2013 !-----------------------------------------------------------------------------
2014 !el      subroutine sc_angular in module geometry
2015 !-----------------------------------------------------------------------------
2016       subroutine e_softsphere(evdw)
2017 !
2018 ! This subroutine calculates the interaction energy of nonbonded side chains
2019 ! assuming the LJ potential of interaction.
2020 !
2021 !      implicit real*8 (a-h,o-z)
2022 !      include 'DIMENSIONS'
2023       real(kind=8),parameter :: accur=1.0d-10
2024 !      include 'COMMON.GEO'
2025 !      include 'COMMON.VAR'
2026 !      include 'COMMON.LOCAL'
2027 !      include 'COMMON.CHAIN'
2028 !      include 'COMMON.DERIV'
2029 !      include 'COMMON.INTERACT'
2030 !      include 'COMMON.TORSION'
2031 !      include 'COMMON.SBRIDGE'
2032 !      include 'COMMON.NAMES'
2033 !      include 'COMMON.IOUNITS'
2034 !      include 'COMMON.CONTACTS'
2035       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2036 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2037 !el local variables
2038       integer :: i,iint,j,itypi,itypi1,itypj,k
2039       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2040       real(kind=8) :: fac
2041
2042       evdw=0.0D0
2043       do i=iatsc_s,iatsc_e
2044         itypi=iabs(itype(i,1))
2045         if (itypi.eq.ntyp1) cycle
2046         itypi1=iabs(itype(i+1,1))
2047         xi=c(1,nres+i)
2048         yi=c(2,nres+i)
2049         zi=c(3,nres+i)
2050 !
2051 ! Calculate SC interaction energy.
2052 !
2053         do iint=1,nint_gr(i)
2054 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2055 !d   &                  'iend=',iend(i,iint)
2056           do j=istart(i,iint),iend(i,iint)
2057             itypj=iabs(itype(j,1))
2058             if (itypj.eq.ntyp1) cycle
2059             xj=c(1,nres+j)-xi
2060             yj=c(2,nres+j)-yi
2061             zj=c(3,nres+j)-zi
2062             rij=xj*xj+yj*yj+zj*zj
2063 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2064             r0ij=r0(itypi,itypj)
2065             r0ijsq=r0ij*r0ij
2066 !            print *,i,j,r0ij,dsqrt(rij)
2067             if (rij.lt.r0ijsq) then
2068               evdwij=0.25d0*(rij-r0ijsq)**2
2069               fac=rij-r0ijsq
2070             else
2071               evdwij=0.0d0
2072               fac=0.0d0
2073             endif
2074             evdw=evdw+evdwij
2075 !
2076 ! Calculate the components of the gradient in DC and X
2077 !
2078             gg(1)=xj*fac
2079             gg(2)=yj*fac
2080             gg(3)=zj*fac
2081             do k=1,3
2082               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2083               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2084               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2085               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2086             enddo
2087 !grad            do k=i,j-1
2088 !grad              do l=1,3
2089 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2090 !grad              enddo
2091 !grad            enddo
2092           enddo ! j
2093         enddo ! iint
2094       enddo ! i
2095       return
2096       end subroutine e_softsphere
2097 !-----------------------------------------------------------------------------
2098       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2099 !
2100 ! Soft-sphere potential of p-p interaction
2101 !
2102 !      implicit real*8 (a-h,o-z)
2103 !      include 'DIMENSIONS'
2104 !      include 'COMMON.CONTROL'
2105 !      include 'COMMON.IOUNITS'
2106 !      include 'COMMON.GEO'
2107 !      include 'COMMON.VAR'
2108 !      include 'COMMON.LOCAL'
2109 !      include 'COMMON.CHAIN'
2110 !      include 'COMMON.DERIV'
2111 !      include 'COMMON.INTERACT'
2112 !      include 'COMMON.CONTACTS'
2113 !      include 'COMMON.TORSION'
2114 !      include 'COMMON.VECTORS'
2115 !      include 'COMMON.FFIELD'
2116       real(kind=8),dimension(3) :: ggg
2117 !d      write(iout,*) 'In EELEC_soft_sphere'
2118 !el local variables
2119       integer :: i,j,k,num_conti,iteli,itelj
2120       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2121       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2122       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2123
2124       ees=0.0D0
2125       evdw1=0.0D0
2126       eel_loc=0.0d0
2127       eello_turn3=0.0d0
2128       eello_turn4=0.0d0
2129 !el      ind=0
2130       do i=iatel_s,iatel_e
2131         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2132         dxi=dc(1,i)
2133         dyi=dc(2,i)
2134         dzi=dc(3,i)
2135         xmedi=c(1,i)+0.5d0*dxi
2136         ymedi=c(2,i)+0.5d0*dyi
2137         zmedi=c(3,i)+0.5d0*dzi
2138         num_conti=0
2139 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2140         do j=ielstart(i),ielend(i)
2141           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2142 !el          ind=ind+1
2143           iteli=itel(i)
2144           itelj=itel(j)
2145           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2146           r0ij=rpp(iteli,itelj)
2147           r0ijsq=r0ij*r0ij
2148           dxj=dc(1,j)
2149           dyj=dc(2,j)
2150           dzj=dc(3,j)
2151           xj=c(1,j)+0.5D0*dxj-xmedi
2152           yj=c(2,j)+0.5D0*dyj-ymedi
2153           zj=c(3,j)+0.5D0*dzj-zmedi
2154           rij=xj*xj+yj*yj+zj*zj
2155           if (rij.lt.r0ijsq) then
2156             evdw1ij=0.25d0*(rij-r0ijsq)**2
2157             fac=rij-r0ijsq
2158           else
2159             evdw1ij=0.0d0
2160             fac=0.0d0
2161           endif
2162           evdw1=evdw1+evdw1ij
2163 !
2164 ! Calculate contributions to the Cartesian gradient.
2165 !
2166           ggg(1)=fac*xj
2167           ggg(2)=fac*yj
2168           ggg(3)=fac*zj
2169           do k=1,3
2170             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2171             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2172           enddo
2173 !
2174 ! Loop over residues i+1 thru j-1.
2175 !
2176 !grad          do k=i+1,j-1
2177 !grad            do l=1,3
2178 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2179 !grad            enddo
2180 !grad          enddo
2181         enddo ! j
2182       enddo   ! i
2183 !grad      do i=nnt,nct-1
2184 !grad        do k=1,3
2185 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2186 !grad        enddo
2187 !grad        do j=i+1,nct-1
2188 !grad          do k=1,3
2189 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2190 !grad          enddo
2191 !grad        enddo
2192 !grad      enddo
2193       return
2194       end subroutine eelec_soft_sphere
2195 !-----------------------------------------------------------------------------
2196       subroutine vec_and_deriv
2197 !      implicit real*8 (a-h,o-z)
2198 !      include 'DIMENSIONS'
2199 #ifdef MPI
2200       include 'mpif.h'
2201 #endif
2202 !      include 'COMMON.IOUNITS'
2203 !      include 'COMMON.GEO'
2204 !      include 'COMMON.VAR'
2205 !      include 'COMMON.LOCAL'
2206 !      include 'COMMON.CHAIN'
2207 !      include 'COMMON.VECTORS'
2208 !      include 'COMMON.SETUP'
2209 !      include 'COMMON.TIME1'
2210       real(kind=8),dimension(3,3,2) :: uyder,uzder
2211       real(kind=8),dimension(2) :: vbld_inv_temp
2212 ! Compute the local reference systems. For reference system (i), the
2213 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2214 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2215 !el local variables
2216       integer :: i,j,k,l
2217       real(kind=8) :: facy,fac,costh
2218
2219 #ifdef PARVEC
2220       do i=ivec_start,ivec_end
2221 #else
2222       do i=1,nres-1
2223 #endif
2224           if (i.eq.nres-1) then
2225 ! Case of the last full residue
2226 ! Compute the Z-axis
2227             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2228             costh=dcos(pi-theta(nres))
2229             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2230             do k=1,3
2231               uz(k,i)=fac*uz(k,i)
2232             enddo
2233 ! Compute the derivatives of uz
2234             uzder(1,1,1)= 0.0d0
2235             uzder(2,1,1)=-dc_norm(3,i-1)
2236             uzder(3,1,1)= dc_norm(2,i-1)
2237             uzder(1,2,1)= dc_norm(3,i-1)
2238             uzder(2,2,1)= 0.0d0
2239             uzder(3,2,1)=-dc_norm(1,i-1)
2240             uzder(1,3,1)=-dc_norm(2,i-1)
2241             uzder(2,3,1)= dc_norm(1,i-1)
2242             uzder(3,3,1)= 0.0d0
2243             uzder(1,1,2)= 0.0d0
2244             uzder(2,1,2)= dc_norm(3,i)
2245             uzder(3,1,2)=-dc_norm(2,i)
2246             uzder(1,2,2)=-dc_norm(3,i)
2247             uzder(2,2,2)= 0.0d0
2248             uzder(3,2,2)= dc_norm(1,i)
2249             uzder(1,3,2)= dc_norm(2,i)
2250             uzder(2,3,2)=-dc_norm(1,i)
2251             uzder(3,3,2)= 0.0d0
2252 ! Compute the Y-axis
2253             facy=fac
2254             do k=1,3
2255               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2256             enddo
2257 ! Compute the derivatives of uy
2258             do j=1,3
2259               do k=1,3
2260                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2261                               -dc_norm(k,i)*dc_norm(j,i-1)
2262                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2263               enddo
2264               uyder(j,j,1)=uyder(j,j,1)-costh
2265               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2266             enddo
2267             do j=1,2
2268               do k=1,3
2269                 do l=1,3
2270                   uygrad(l,k,j,i)=uyder(l,k,j)
2271                   uzgrad(l,k,j,i)=uzder(l,k,j)
2272                 enddo
2273               enddo
2274             enddo
2275             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2276             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2277             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2278             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2279           else
2280 ! Other residues
2281 ! Compute the Z-axis
2282             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2283             costh=dcos(pi-theta(i+2))
2284             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2285             do k=1,3
2286               uz(k,i)=fac*uz(k,i)
2287             enddo
2288 ! Compute the derivatives of uz
2289             uzder(1,1,1)= 0.0d0
2290             uzder(2,1,1)=-dc_norm(3,i+1)
2291             uzder(3,1,1)= dc_norm(2,i+1)
2292             uzder(1,2,1)= dc_norm(3,i+1)
2293             uzder(2,2,1)= 0.0d0
2294             uzder(3,2,1)=-dc_norm(1,i+1)
2295             uzder(1,3,1)=-dc_norm(2,i+1)
2296             uzder(2,3,1)= dc_norm(1,i+1)
2297             uzder(3,3,1)= 0.0d0
2298             uzder(1,1,2)= 0.0d0
2299             uzder(2,1,2)= dc_norm(3,i)
2300             uzder(3,1,2)=-dc_norm(2,i)
2301             uzder(1,2,2)=-dc_norm(3,i)
2302             uzder(2,2,2)= 0.0d0
2303             uzder(3,2,2)= dc_norm(1,i)
2304             uzder(1,3,2)= dc_norm(2,i)
2305             uzder(2,3,2)=-dc_norm(1,i)
2306             uzder(3,3,2)= 0.0d0
2307 ! Compute the Y-axis
2308             facy=fac
2309             do k=1,3
2310               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2311             enddo
2312 ! Compute the derivatives of uy
2313             do j=1,3
2314               do k=1,3
2315                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2316                               -dc_norm(k,i)*dc_norm(j,i+1)
2317                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2318               enddo
2319               uyder(j,j,1)=uyder(j,j,1)-costh
2320               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2321             enddo
2322             do j=1,2
2323               do k=1,3
2324                 do l=1,3
2325                   uygrad(l,k,j,i)=uyder(l,k,j)
2326                   uzgrad(l,k,j,i)=uzder(l,k,j)
2327                 enddo
2328               enddo
2329             enddo
2330             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2331             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2332             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2333             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2334           endif
2335       enddo
2336       do i=1,nres-1
2337         vbld_inv_temp(1)=vbld_inv(i+1)
2338         if (i.lt.nres-1) then
2339           vbld_inv_temp(2)=vbld_inv(i+2)
2340           else
2341           vbld_inv_temp(2)=vbld_inv(i)
2342           endif
2343         do j=1,2
2344           do k=1,3
2345             do l=1,3
2346               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2347               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2348             enddo
2349           enddo
2350         enddo
2351       enddo
2352 #if defined(PARVEC) && defined(MPI)
2353       if (nfgtasks1.gt.1) then
2354         time00=MPI_Wtime()
2355 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2356 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2357 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2358         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2359          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2360          FG_COMM1,IERR)
2361         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2362          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2363          FG_COMM1,IERR)
2364         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2365          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2366          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2367         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2368          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2369          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2370         time_gather=time_gather+MPI_Wtime()-time00
2371       endif
2372 !      if (fg_rank.eq.0) then
2373 !        write (iout,*) "Arrays UY and UZ"
2374 !        do i=1,nres-1
2375 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2376 !     &     (uz(k,i),k=1,3)
2377 !        enddo
2378 !      endif
2379 #endif
2380       return
2381       end subroutine vec_and_deriv
2382 !-----------------------------------------------------------------------------
2383       subroutine check_vecgrad
2384 !      implicit real*8 (a-h,o-z)
2385 !      include 'DIMENSIONS'
2386 !      include 'COMMON.IOUNITS'
2387 !      include 'COMMON.GEO'
2388 !      include 'COMMON.VAR'
2389 !      include 'COMMON.LOCAL'
2390 !      include 'COMMON.CHAIN'
2391 !      include 'COMMON.VECTORS'
2392       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2393       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2394       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2395       real(kind=8),dimension(3) :: erij
2396       real(kind=8) :: delta=1.0d-7
2397 !el local variables
2398       integer :: i,j,k,l
2399
2400       call vec_and_deriv
2401 !d      do i=1,nres
2402 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2403 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2404 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2405 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2406 !d     &     (dc_norm(if90,i),if90=1,3)
2407 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2408 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2409 !d          write(iout,'(a)')
2410 !d      enddo
2411       do i=1,nres
2412         do j=1,2
2413           do k=1,3
2414             do l=1,3
2415               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2416               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2417             enddo
2418           enddo
2419         enddo
2420       enddo
2421       call vec_and_deriv
2422       do i=1,nres
2423         do j=1,3
2424           uyt(j,i)=uy(j,i)
2425           uzt(j,i)=uz(j,i)
2426         enddo
2427       enddo
2428       do i=1,nres
2429 !d        write (iout,*) 'i=',i
2430         do k=1,3
2431           erij(k)=dc_norm(k,i)
2432         enddo
2433         do j=1,3
2434           do k=1,3
2435             dc_norm(k,i)=erij(k)
2436           enddo
2437           dc_norm(j,i)=dc_norm(j,i)+delta
2438 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2439 !          do k=1,3
2440 !            dc_norm(k,i)=dc_norm(k,i)/fac
2441 !          enddo
2442 !          write (iout,*) (dc_norm(k,i),k=1,3)
2443 !          write (iout,*) (erij(k),k=1,3)
2444           call vec_and_deriv
2445           do k=1,3
2446             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2447             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2448             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2449             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2450           enddo
2451 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2452 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2453 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2454         enddo
2455         do k=1,3
2456           dc_norm(k,i)=erij(k)
2457         enddo
2458 !d        do k=1,3
2459 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2460 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2461 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2462 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2463 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2464 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2465 !d          write (iout,'(a)')
2466 !d        enddo
2467       enddo
2468       return
2469       end subroutine check_vecgrad
2470 !-----------------------------------------------------------------------------
2471       subroutine set_matrices
2472 !      implicit real*8 (a-h,o-z)
2473 !      include 'DIMENSIONS'
2474 #ifdef MPI
2475       include "mpif.h"
2476 !      include "COMMON.SETUP"
2477       integer :: IERR
2478       integer :: status(MPI_STATUS_SIZE)
2479 #endif
2480 !      include 'COMMON.IOUNITS'
2481 !      include 'COMMON.GEO'
2482 !      include 'COMMON.VAR'
2483 !      include 'COMMON.LOCAL'
2484 !      include 'COMMON.CHAIN'
2485 !      include 'COMMON.DERIV'
2486 !      include 'COMMON.INTERACT'
2487 !      include 'COMMON.CONTACTS'
2488 !      include 'COMMON.TORSION'
2489 !      include 'COMMON.VECTORS'
2490 !      include 'COMMON.FFIELD'
2491       real(kind=8) :: auxvec(2),auxmat(2,2)
2492       integer :: i,iti1,iti,k,l
2493       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2494 !       print *,"in set matrices"
2495 !
2496 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2497 ! to calculate the el-loc multibody terms of various order.
2498 !
2499 !AL el      mu=0.0d0
2500 #ifdef PARMAT
2501       do i=ivec_start+2,ivec_end+2
2502 #else
2503       do i=3,nres+1
2504 #endif
2505 !      print *,i,"i"
2506         if (i .lt. nres+1) then
2507           sin1=dsin(phi(i))
2508           cos1=dcos(phi(i))
2509           sintab(i-2)=sin1
2510           costab(i-2)=cos1
2511           obrot(1,i-2)=cos1
2512           obrot(2,i-2)=sin1
2513           sin2=dsin(2*phi(i))
2514           cos2=dcos(2*phi(i))
2515           sintab2(i-2)=sin2
2516           costab2(i-2)=cos2
2517           obrot2(1,i-2)=cos2
2518           obrot2(2,i-2)=sin2
2519           Ug(1,1,i-2)=-cos1
2520           Ug(1,2,i-2)=-sin1
2521           Ug(2,1,i-2)=-sin1
2522           Ug(2,2,i-2)= cos1
2523           Ug2(1,1,i-2)=-cos2
2524           Ug2(1,2,i-2)=-sin2
2525           Ug2(2,1,i-2)=-sin2
2526           Ug2(2,2,i-2)= cos2
2527         else
2528           costab(i-2)=1.0d0
2529           sintab(i-2)=0.0d0
2530           obrot(1,i-2)=1.0d0
2531           obrot(2,i-2)=0.0d0
2532           obrot2(1,i-2)=0.0d0
2533           obrot2(2,i-2)=0.0d0
2534           Ug(1,1,i-2)=1.0d0
2535           Ug(1,2,i-2)=0.0d0
2536           Ug(2,1,i-2)=0.0d0
2537           Ug(2,2,i-2)=1.0d0
2538           Ug2(1,1,i-2)=0.0d0
2539           Ug2(1,2,i-2)=0.0d0
2540           Ug2(2,1,i-2)=0.0d0
2541           Ug2(2,2,i-2)=0.0d0
2542         endif
2543         if (i .gt. 3 .and. i .lt. nres+1) then
2544           obrot_der(1,i-2)=-sin1
2545           obrot_der(2,i-2)= cos1
2546           Ugder(1,1,i-2)= sin1
2547           Ugder(1,2,i-2)=-cos1
2548           Ugder(2,1,i-2)=-cos1
2549           Ugder(2,2,i-2)=-sin1
2550           dwacos2=cos2+cos2
2551           dwasin2=sin2+sin2
2552           obrot2_der(1,i-2)=-dwasin2
2553           obrot2_der(2,i-2)= dwacos2
2554           Ug2der(1,1,i-2)= dwasin2
2555           Ug2der(1,2,i-2)=-dwacos2
2556           Ug2der(2,1,i-2)=-dwacos2
2557           Ug2der(2,2,i-2)=-dwasin2
2558         else
2559           obrot_der(1,i-2)=0.0d0
2560           obrot_der(2,i-2)=0.0d0
2561           Ugder(1,1,i-2)=0.0d0
2562           Ugder(1,2,i-2)=0.0d0
2563           Ugder(2,1,i-2)=0.0d0
2564           Ugder(2,2,i-2)=0.0d0
2565           obrot2_der(1,i-2)=0.0d0
2566           obrot2_der(2,i-2)=0.0d0
2567           Ug2der(1,1,i-2)=0.0d0
2568           Ug2der(1,2,i-2)=0.0d0
2569           Ug2der(2,1,i-2)=0.0d0
2570           Ug2der(2,2,i-2)=0.0d0
2571         endif
2572 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2573         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2574            if (itype(i-2,1).eq.0) then
2575           iti=ntortyp+1
2576            else
2577           iti = itortyp(itype(i-2,1))
2578            endif
2579         else
2580           iti=ntortyp+1
2581         endif
2582 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2583         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2584            if (itype(i-1,1).eq.0) then
2585           iti1=ntortyp+1
2586            else
2587           iti1 = itortyp(itype(i-1,1))
2588            endif
2589         else
2590           iti1=ntortyp+1
2591         endif
2592 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2593 !d        write (iout,*) '*******i',i,' iti1',iti
2594 !d        write (iout,*) 'b1',b1(:,iti)
2595 !d        write (iout,*) 'b2',b2(:,iti)
2596 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2597 !        if (i .gt. iatel_s+2) then
2598         if (i .gt. nnt+2) then
2599           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2600           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2601           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2602           then
2603           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2604           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2605           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2606           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2607           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2608           endif
2609         else
2610           do k=1,2
2611             Ub2(k,i-2)=0.0d0
2612             Ctobr(k,i-2)=0.0d0
2613             Dtobr2(k,i-2)=0.0d0
2614             do l=1,2
2615               EUg(l,k,i-2)=0.0d0
2616               CUg(l,k,i-2)=0.0d0
2617               DUg(l,k,i-2)=0.0d0
2618               DtUg2(l,k,i-2)=0.0d0
2619             enddo
2620           enddo
2621         endif
2622         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2623         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2624         do k=1,2
2625           muder(k,i-2)=Ub2der(k,i-2)
2626         enddo
2627 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2628         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2629           if (itype(i-1,1).eq.0) then
2630            iti1=ntortyp+1
2631           elseif (itype(i-1,1).le.ntyp) then
2632             iti1 = itortyp(itype(i-1,1))
2633           else
2634             iti1=ntortyp+1
2635           endif
2636         else
2637           iti1=ntortyp+1
2638         endif
2639         do k=1,2
2640           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2641         enddo
2642 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2643 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2644 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2645 !d        write (iout,*) 'mu1',mu1(:,i-2)
2646 !d        write (iout,*) 'mu2',mu2(:,i-2)
2647         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2648         then
2649         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2650         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2651         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2652         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2653         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2654 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2655         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2656         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2657         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2658         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2659         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2660         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2661         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2662         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2663         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2664         endif
2665       enddo
2666 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2667 ! The order of matrices is from left to right.
2668       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2669       then
2670 !      do i=max0(ivec_start,2),ivec_end
2671       do i=2,nres-1
2672         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2673         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2674         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2675         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2676         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2677         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2678         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2679         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2680       enddo
2681       endif
2682 #if defined(MPI) && defined(PARMAT)
2683 #ifdef DEBUG
2684 !      if (fg_rank.eq.0) then
2685         write (iout,*) "Arrays UG and UGDER before GATHER"
2686         do i=1,nres-1
2687           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2688            ((ug(l,k,i),l=1,2),k=1,2),&
2689            ((ugder(l,k,i),l=1,2),k=1,2)
2690         enddo
2691         write (iout,*) "Arrays UG2 and UG2DER"
2692         do i=1,nres-1
2693           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2694            ((ug2(l,k,i),l=1,2),k=1,2),&
2695            ((ug2der(l,k,i),l=1,2),k=1,2)
2696         enddo
2697         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2698         do i=1,nres-1
2699           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2700            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2701            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2702         enddo
2703         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2704         do i=1,nres-1
2705           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2706            costab(i),sintab(i),costab2(i),sintab2(i)
2707         enddo
2708         write (iout,*) "Array MUDER"
2709         do i=1,nres-1
2710           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2711         enddo
2712 !      endif
2713 #endif
2714       if (nfgtasks.gt.1) then
2715         time00=MPI_Wtime()
2716 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2717 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2718 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2719 #ifdef MATGATHER
2720         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2721          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2722          FG_COMM1,IERR)
2723         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2724          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2725          FG_COMM1,IERR)
2726         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2727          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2728          FG_COMM1,IERR)
2729         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2730          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2731          FG_COMM1,IERR)
2732         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2733          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2734          FG_COMM1,IERR)
2735         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2736          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2737          FG_COMM1,IERR)
2738         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2739          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2740          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2741         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2742          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2743          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2744         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2745          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2746          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2747         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2748          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2749          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2750         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2751         then
2752         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2753          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2754          FG_COMM1,IERR)
2755         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2756          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2757          FG_COMM1,IERR)
2758         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2759          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2760          FG_COMM1,IERR)
2761        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2762          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2763          FG_COMM1,IERR)
2764         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2765          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2766          FG_COMM1,IERR)
2767         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2768          ivec_count(fg_rank1),&
2769          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2770          FG_COMM1,IERR)
2771         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2772          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2773          FG_COMM1,IERR)
2774         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2775          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2776          FG_COMM1,IERR)
2777         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2778          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2779          FG_COMM1,IERR)
2780         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2781          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2782          FG_COMM1,IERR)
2783         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2784          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2785          FG_COMM1,IERR)
2786         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2787          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2788          FG_COMM1,IERR)
2789         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2790          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2791          FG_COMM1,IERR)
2792         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2793          ivec_count(fg_rank1),&
2794          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2795          FG_COMM1,IERR)
2796         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2797          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2798          FG_COMM1,IERR)
2799        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2800          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2801          FG_COMM1,IERR)
2802         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2803          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2804          FG_COMM1,IERR)
2805        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2806          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2807          FG_COMM1,IERR)
2808         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2809          ivec_count(fg_rank1),&
2810          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2811          FG_COMM1,IERR)
2812         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2813          ivec_count(fg_rank1),&
2814          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2815          FG_COMM1,IERR)
2816         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2817          ivec_count(fg_rank1),&
2818          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2819          MPI_MAT2,FG_COMM1,IERR)
2820         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2821          ivec_count(fg_rank1),&
2822          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2823          MPI_MAT2,FG_COMM1,IERR)
2824         endif
2825 #else
2826 ! Passes matrix info through the ring
2827       isend=fg_rank1
2828       irecv=fg_rank1-1
2829       if (irecv.lt.0) irecv=nfgtasks1-1
2830       iprev=irecv
2831       inext=fg_rank1+1
2832       if (inext.ge.nfgtasks1) inext=0
2833       do i=1,nfgtasks1-1
2834 !        write (iout,*) "isend",isend," irecv",irecv
2835 !        call flush(iout)
2836         lensend=lentyp(isend)
2837         lenrecv=lentyp(irecv)
2838 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2839 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2840 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2841 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2842 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2843 !        write (iout,*) "Gather ROTAT1"
2844 !        call flush(iout)
2845 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2846 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2847 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2848 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2849 !        write (iout,*) "Gather ROTAT2"
2850 !        call flush(iout)
2851         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2852          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2853          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2854          iprev,4400+irecv,FG_COMM,status,IERR)
2855 !        write (iout,*) "Gather ROTAT_OLD"
2856 !        call flush(iout)
2857         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2858          MPI_PRECOMP11(lensend),inext,5500+isend,&
2859          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2860          iprev,5500+irecv,FG_COMM,status,IERR)
2861 !        write (iout,*) "Gather PRECOMP11"
2862 !        call flush(iout)
2863         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2864          MPI_PRECOMP12(lensend),inext,6600+isend,&
2865          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2866          iprev,6600+irecv,FG_COMM,status,IERR)
2867 !        write (iout,*) "Gather PRECOMP12"
2868 !        call flush(iout)
2869         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2870         then
2871         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2872          MPI_ROTAT2(lensend),inext,7700+isend,&
2873          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2874          iprev,7700+irecv,FG_COMM,status,IERR)
2875 !        write (iout,*) "Gather PRECOMP21"
2876 !        call flush(iout)
2877         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2878          MPI_PRECOMP22(lensend),inext,8800+isend,&
2879          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2880          iprev,8800+irecv,FG_COMM,status,IERR)
2881 !        write (iout,*) "Gather PRECOMP22"
2882 !        call flush(iout)
2883         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2884          MPI_PRECOMP23(lensend),inext,9900+isend,&
2885          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2886          MPI_PRECOMP23(lenrecv),&
2887          iprev,9900+irecv,FG_COMM,status,IERR)
2888 !        write (iout,*) "Gather PRECOMP23"
2889 !        call flush(iout)
2890         endif
2891         isend=irecv
2892         irecv=irecv-1
2893         if (irecv.lt.0) irecv=nfgtasks1-1
2894       enddo
2895 #endif
2896         time_gather=time_gather+MPI_Wtime()-time00
2897       endif
2898 #ifdef DEBUG
2899 !      if (fg_rank.eq.0) then
2900         write (iout,*) "Arrays UG and UGDER"
2901         do i=1,nres-1
2902           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2903            ((ug(l,k,i),l=1,2),k=1,2),&
2904            ((ugder(l,k,i),l=1,2),k=1,2)
2905         enddo
2906         write (iout,*) "Arrays UG2 and UG2DER"
2907         do i=1,nres-1
2908           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2909            ((ug2(l,k,i),l=1,2),k=1,2),&
2910            ((ug2der(l,k,i),l=1,2),k=1,2)
2911         enddo
2912         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2913         do i=1,nres-1
2914           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2915            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2916            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2917         enddo
2918         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2919         do i=1,nres-1
2920           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2921            costab(i),sintab(i),costab2(i),sintab2(i)
2922         enddo
2923         write (iout,*) "Array MUDER"
2924         do i=1,nres-1
2925           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2926         enddo
2927 !      endif
2928 #endif
2929 #endif
2930 !d      do i=1,nres
2931 !d        iti = itortyp(itype(i,1))
2932 !d        write (iout,*) i
2933 !d        do j=1,2
2934 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2935 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2936 !d        enddo
2937 !d      enddo
2938       return
2939       end subroutine set_matrices
2940 !-----------------------------------------------------------------------------
2941       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2942 !
2943 ! This subroutine calculates the average interaction energy and its gradient
2944 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2945 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2946 ! The potential depends both on the distance of peptide-group centers and on
2947 ! the orientation of the CA-CA virtual bonds.
2948 !
2949       use comm_locel
2950 !      implicit real*8 (a-h,o-z)
2951 #ifdef MPI
2952       include 'mpif.h'
2953 #endif
2954 !      include 'DIMENSIONS'
2955 !      include 'COMMON.CONTROL'
2956 !      include 'COMMON.SETUP'
2957 !      include 'COMMON.IOUNITS'
2958 !      include 'COMMON.GEO'
2959 !      include 'COMMON.VAR'
2960 !      include 'COMMON.LOCAL'
2961 !      include 'COMMON.CHAIN'
2962 !      include 'COMMON.DERIV'
2963 !      include 'COMMON.INTERACT'
2964 !      include 'COMMON.CONTACTS'
2965 !      include 'COMMON.TORSION'
2966 !      include 'COMMON.VECTORS'
2967 !      include 'COMMON.FFIELD'
2968 !      include 'COMMON.TIME1'
2969       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2970       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2971       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2972 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2973       real(kind=8),dimension(4) :: muij
2974 !el      integer :: num_conti,j1,j2
2975 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2976 !el        dz_normi,xmedi,ymedi,zmedi
2977
2978 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2979 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2980 !el          num_conti,j1,j2
2981
2982 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2983 #ifdef MOMENT
2984       real(kind=8) :: scal_el=1.0d0
2985 #else
2986       real(kind=8) :: scal_el=0.5d0
2987 #endif
2988 ! 12/13/98
2989 ! 13-go grudnia roku pamietnego...
2990       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2991                                              0.0d0,1.0d0,0.0d0,&
2992                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2993 !el local variables
2994       integer :: i,k,j
2995       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2996       real(kind=8) :: fac,t_eelecij,fracinbuf
2997
2998
2999 !d      write(iout,*) 'In EELEC'
3000 !        print *,"IN EELEC"
3001 !d      do i=1,nloctyp
3002 !d        write(iout,*) 'Type',i
3003 !d        write(iout,*) 'B1',B1(:,i)
3004 !d        write(iout,*) 'B2',B2(:,i)
3005 !d        write(iout,*) 'CC',CC(:,:,i)
3006 !d        write(iout,*) 'DD',DD(:,:,i)
3007 !d        write(iout,*) 'EE',EE(:,:,i)
3008 !d      enddo
3009 !d      call check_vecgrad
3010 !d      stop
3011 !      ees=0.0d0  !AS
3012 !      evdw1=0.0d0
3013 !      eel_loc=0.0d0
3014 !      eello_turn3=0.0d0
3015 !      eello_turn4=0.0d0
3016       t_eelecij=0.0d0
3017       ees=0.0D0
3018       evdw1=0.0D0
3019       eel_loc=0.0d0
3020       eello_turn3=0.0d0
3021       eello_turn4=0.0d0
3022 !
3023
3024       if (icheckgrad.eq.1) then
3025 !el
3026 !        do i=0,2*nres+2
3027 !          dc_norm(1,i)=0.0d0
3028 !          dc_norm(2,i)=0.0d0
3029 !          dc_norm(3,i)=0.0d0
3030 !        enddo
3031         do i=1,nres-1
3032           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3033           do k=1,3
3034             dc_norm(k,i)=dc(k,i)*fac
3035           enddo
3036 !          write (iout,*) 'i',i,' fac',fac
3037         enddo
3038       endif
3039 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3040 !        wturn6
3041       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3042           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3043           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3044 !        call vec_and_deriv
3045 #ifdef TIMING
3046         time01=MPI_Wtime()
3047 #endif
3048 !        print *, "before set matrices"
3049         call set_matrices
3050 !        print *, "after set matrices"
3051
3052 #ifdef TIMING
3053         time_mat=time_mat+MPI_Wtime()-time01
3054 #endif
3055       endif
3056 !       print *, "after set matrices"
3057 !d      do i=1,nres-1
3058 !d        write (iout,*) 'i=',i
3059 !d        do k=1,3
3060 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3061 !d        enddo
3062 !d        do k=1,3
3063 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3064 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3065 !d        enddo
3066 !d      enddo
3067       t_eelecij=0.0d0
3068       ees=0.0D0
3069       evdw1=0.0D0
3070       eel_loc=0.0d0
3071       eello_turn3=0.0d0
3072       eello_turn4=0.0d0
3073 !el      ind=0
3074       do i=1,nres
3075         num_cont_hb(i)=0
3076       enddo
3077 !d      print '(a)','Enter EELEC'
3078 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3079 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3080 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3081       do i=1,nres
3082         gel_loc_loc(i)=0.0d0
3083         gcorr_loc(i)=0.0d0
3084       enddo
3085 !
3086 !
3087 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3088 !
3089 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3090 !
3091
3092
3093 !        print *,"before iturn3 loop"
3094       do i=iturn3_start,iturn3_end
3095         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3096         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3097         dxi=dc(1,i)
3098         dyi=dc(2,i)
3099         dzi=dc(3,i)
3100         dx_normi=dc_norm(1,i)
3101         dy_normi=dc_norm(2,i)
3102         dz_normi=dc_norm(3,i)
3103         xmedi=c(1,i)+0.5d0*dxi
3104         ymedi=c(2,i)+0.5d0*dyi
3105         zmedi=c(3,i)+0.5d0*dzi
3106           xmedi=dmod(xmedi,boxxsize)
3107           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3108           ymedi=dmod(ymedi,boxysize)
3109           if (ymedi.lt.0) ymedi=ymedi+boxysize
3110           zmedi=dmod(zmedi,boxzsize)
3111           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3112         num_conti=0
3113        if ((zmedi.gt.bordlipbot) &
3114         .and.(zmedi.lt.bordliptop)) then
3115 !C the energy transfer exist
3116         if (zmedi.lt.buflipbot) then
3117 !C what fraction I am in
3118          fracinbuf=1.0d0- &
3119                ((zmedi-bordlipbot)/lipbufthick)
3120 !C lipbufthick is thickenes of lipid buffore
3121          sslipi=sscalelip(fracinbuf)
3122          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3123         elseif (zmedi.gt.bufliptop) then
3124          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3125          sslipi=sscalelip(fracinbuf)
3126          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3127         else
3128          sslipi=1.0d0
3129          ssgradlipi=0.0
3130         endif
3131        else
3132          sslipi=0.0d0
3133          ssgradlipi=0.0
3134        endif
3135 !       print *,i,sslipi,ssgradlipi
3136        call eelecij(i,i+2,ees,evdw1,eel_loc)
3137         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3138         num_cont_hb(i)=num_conti
3139       enddo
3140       do i=iturn4_start,iturn4_end
3141         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3142           .or. itype(i+3,1).eq.ntyp1 &
3143           .or. itype(i+4,1).eq.ntyp1) cycle
3144         dxi=dc(1,i)
3145         dyi=dc(2,i)
3146         dzi=dc(3,i)
3147         dx_normi=dc_norm(1,i)
3148         dy_normi=dc_norm(2,i)
3149         dz_normi=dc_norm(3,i)
3150         xmedi=c(1,i)+0.5d0*dxi
3151         ymedi=c(2,i)+0.5d0*dyi
3152         zmedi=c(3,i)+0.5d0*dzi
3153           xmedi=dmod(xmedi,boxxsize)
3154           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3155           ymedi=dmod(ymedi,boxysize)
3156           if (ymedi.lt.0) ymedi=ymedi+boxysize
3157           zmedi=dmod(zmedi,boxzsize)
3158           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3159        if ((zmedi.gt.bordlipbot)  &
3160        .and.(zmedi.lt.bordliptop)) then
3161 !C the energy transfer exist
3162         if (zmedi.lt.buflipbot) then
3163 !C what fraction I am in
3164          fracinbuf=1.0d0- &
3165              ((zmedi-bordlipbot)/lipbufthick)
3166 !C lipbufthick is thickenes of lipid buffore
3167          sslipi=sscalelip(fracinbuf)
3168          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3169         elseif (zmedi.gt.bufliptop) then
3170          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3171          sslipi=sscalelip(fracinbuf)
3172          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3173         else
3174          sslipi=1.0d0
3175          ssgradlipi=0.0
3176         endif
3177        else
3178          sslipi=0.0d0
3179          ssgradlipi=0.0
3180        endif
3181
3182         num_conti=num_cont_hb(i)
3183         call eelecij(i,i+3,ees,evdw1,eel_loc)
3184         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3185          call eturn4(i,eello_turn4)
3186         num_cont_hb(i)=num_conti
3187       enddo   ! i
3188 !
3189 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3190 !
3191 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3192       do i=iatel_s,iatel_e
3193         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3194         dxi=dc(1,i)
3195         dyi=dc(2,i)
3196         dzi=dc(3,i)
3197         dx_normi=dc_norm(1,i)
3198         dy_normi=dc_norm(2,i)
3199         dz_normi=dc_norm(3,i)
3200         xmedi=c(1,i)+0.5d0*dxi
3201         ymedi=c(2,i)+0.5d0*dyi
3202         zmedi=c(3,i)+0.5d0*dzi
3203           xmedi=dmod(xmedi,boxxsize)
3204           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3205           ymedi=dmod(ymedi,boxysize)
3206           if (ymedi.lt.0) ymedi=ymedi+boxysize
3207           zmedi=dmod(zmedi,boxzsize)
3208           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3209        if ((zmedi.gt.bordlipbot)  &
3210         .and.(zmedi.lt.bordliptop)) then
3211 !C the energy transfer exist
3212         if (zmedi.lt.buflipbot) then
3213 !C what fraction I am in
3214          fracinbuf=1.0d0- &
3215              ((zmedi-bordlipbot)/lipbufthick)
3216 !C lipbufthick is thickenes of lipid buffore
3217          sslipi=sscalelip(fracinbuf)
3218          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3219         elseif (zmedi.gt.bufliptop) then
3220          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3221          sslipi=sscalelip(fracinbuf)
3222          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3223         else
3224          sslipi=1.0d0
3225          ssgradlipi=0.0
3226         endif
3227        else
3228          sslipi=0.0d0
3229          ssgradlipi=0.0
3230        endif
3231
3232 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3233         num_conti=num_cont_hb(i)
3234         do j=ielstart(i),ielend(i)
3235 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3236           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3237           call eelecij(i,j,ees,evdw1,eel_loc)
3238         enddo ! j
3239         num_cont_hb(i)=num_conti
3240       enddo   ! i
3241 !      write (iout,*) "Number of loop steps in EELEC:",ind
3242 !d      do i=1,nres
3243 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3244 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3245 !d      enddo
3246 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3247 !cc      eel_loc=eel_loc+eello_turn3
3248 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3249       return
3250       end subroutine eelec
3251 !-----------------------------------------------------------------------------
3252       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3253
3254       use comm_locel
3255 !      implicit real*8 (a-h,o-z)
3256 !      include 'DIMENSIONS'
3257 #ifdef MPI
3258       include "mpif.h"
3259 #endif
3260 !      include 'COMMON.CONTROL'
3261 !      include 'COMMON.IOUNITS'
3262 !      include 'COMMON.GEO'
3263 !      include 'COMMON.VAR'
3264 !      include 'COMMON.LOCAL'
3265 !      include 'COMMON.CHAIN'
3266 !      include 'COMMON.DERIV'
3267 !      include 'COMMON.INTERACT'
3268 !      include 'COMMON.CONTACTS'
3269 !      include 'COMMON.TORSION'
3270 !      include 'COMMON.VECTORS'
3271 !      include 'COMMON.FFIELD'
3272 !      include 'COMMON.TIME1'
3273       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3274       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3275       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3276 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3277       real(kind=8),dimension(4) :: muij
3278       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3279                     dist_temp, dist_init,rlocshield,fracinbuf
3280       integer xshift,yshift,zshift,ilist,iresshield
3281 !el      integer :: num_conti,j1,j2
3282 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3283 !el        dz_normi,xmedi,ymedi,zmedi
3284
3285 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3286 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3287 !el          num_conti,j1,j2
3288
3289 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3290 #ifdef MOMENT
3291       real(kind=8) :: scal_el=1.0d0
3292 #else
3293       real(kind=8) :: scal_el=0.5d0
3294 #endif
3295 ! 12/13/98
3296 ! 13-go grudnia roku pamietnego...
3297       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3298                                              0.0d0,1.0d0,0.0d0,&
3299                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3300 !      integer :: maxconts=nres/4
3301 !el local variables
3302       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3303       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3304       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3305       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3306                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3307                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3308                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3309                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3310                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3311                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3312                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3313 !      maxconts=nres/4
3314 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3315 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3316
3317 !          time00=MPI_Wtime()
3318 !d      write (iout,*) "eelecij",i,j
3319 !          ind=ind+1
3320           iteli=itel(i)
3321           itelj=itel(j)
3322           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3323           aaa=app(iteli,itelj)
3324           bbb=bpp(iteli,itelj)
3325           ael6i=ael6(iteli,itelj)
3326           ael3i=ael3(iteli,itelj)
3327           dxj=dc(1,j)
3328           dyj=dc(2,j)
3329           dzj=dc(3,j)
3330           dx_normj=dc_norm(1,j)
3331           dy_normj=dc_norm(2,j)
3332           dz_normj=dc_norm(3,j)
3333 !          xj=c(1,j)+0.5D0*dxj-xmedi
3334 !          yj=c(2,j)+0.5D0*dyj-ymedi
3335 !          zj=c(3,j)+0.5D0*dzj-zmedi
3336           xj=c(1,j)+0.5D0*dxj
3337           yj=c(2,j)+0.5D0*dyj
3338           zj=c(3,j)+0.5D0*dzj
3339           xj=mod(xj,boxxsize)
3340           if (xj.lt.0) xj=xj+boxxsize
3341           yj=mod(yj,boxysize)
3342           if (yj.lt.0) yj=yj+boxysize
3343           zj=mod(zj,boxzsize)
3344           if (zj.lt.0) zj=zj+boxzsize
3345        if ((zj.gt.bordlipbot)  &
3346        .and.(zj.lt.bordliptop)) then
3347 !C the energy transfer exist
3348         if (zj.lt.buflipbot) then
3349 !C what fraction I am in
3350          fracinbuf=1.0d0-     &
3351              ((zj-bordlipbot)/lipbufthick)
3352 !C lipbufthick is thickenes of lipid buffore
3353          sslipj=sscalelip(fracinbuf)
3354          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3355         elseif (zj.gt.bufliptop) then
3356          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3357          sslipj=sscalelip(fracinbuf)
3358          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3359         else
3360          sslipj=1.0d0
3361          ssgradlipj=0.0
3362         endif
3363        else
3364          sslipj=0.0d0
3365          ssgradlipj=0.0
3366        endif
3367
3368       isubchap=0
3369       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3370       xj_safe=xj
3371       yj_safe=yj
3372       zj_safe=zj
3373       do xshift=-1,1
3374       do yshift=-1,1
3375       do zshift=-1,1
3376           xj=xj_safe+xshift*boxxsize
3377           yj=yj_safe+yshift*boxysize
3378           zj=zj_safe+zshift*boxzsize
3379           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3380           if(dist_temp.lt.dist_init) then
3381             dist_init=dist_temp
3382             xj_temp=xj
3383             yj_temp=yj
3384             zj_temp=zj
3385             isubchap=1
3386           endif
3387        enddo
3388        enddo
3389        enddo
3390        if (isubchap.eq.1) then
3391 !C          print *,i,j
3392           xj=xj_temp-xmedi
3393           yj=yj_temp-ymedi
3394           zj=zj_temp-zmedi
3395        else
3396           xj=xj_safe-xmedi
3397           yj=yj_safe-ymedi
3398           zj=zj_safe-zmedi
3399        endif
3400
3401           rij=xj*xj+yj*yj+zj*zj
3402           rrmij=1.0D0/rij
3403           rij=dsqrt(rij)
3404 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3405             sss_ele_cut=sscale_ele(rij)
3406             sss_ele_grad=sscagrad_ele(rij)
3407 !             sss_ele_cut=1.0d0
3408 !             sss_ele_grad=0.0d0
3409 !            print *,sss_ele_cut,sss_ele_grad,&
3410 !            (rij),r_cut_ele,rlamb_ele
3411 !            if (sss_ele_cut.le.0.0) go to 128
3412
3413           rmij=1.0D0/rij
3414           r3ij=rrmij*rmij
3415           r6ij=r3ij*r3ij
3416           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3417           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3418           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3419           fac=cosa-3.0D0*cosb*cosg
3420           ev1=aaa*r6ij*r6ij
3421 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3422           if (j.eq.i+2) ev1=scal_el*ev1
3423           ev2=bbb*r6ij
3424           fac3=ael6i*r6ij
3425           fac4=ael3i*r3ij
3426           evdwij=ev1+ev2
3427           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3428           el2=fac4*fac
3429 !          eesij=el1+el2
3430           if (shield_mode.gt.0) then
3431 !C          fac_shield(i)=0.4
3432 !C          fac_shield(j)=0.6
3433           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3434           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3435           eesij=(el1+el2)
3436           ees=ees+eesij*sss_ele_cut
3437 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3438 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3439           else
3440           fac_shield(i)=1.0
3441           fac_shield(j)=1.0
3442           eesij=(el1+el2)
3443           ees=ees+eesij   &
3444             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3445 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3446           endif
3447
3448 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3449           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3450 !          ees=ees+eesij*sss_ele_cut
3451           evdw1=evdw1+evdwij*sss_ele_cut  &
3452            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3453 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3454 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3455 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3456 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3457
3458           if (energy_dec) then
3459 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3460 !                  'evdw1',i,j,evdwij,&
3461 !                  iteli,itelj,aaa,evdw1
3462               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3463               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3464           endif
3465 !
3466 ! Calculate contributions to the Cartesian gradient.
3467 !
3468 #ifdef SPLITELE
3469           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3470               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3471           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3472              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3473           fac1=fac
3474           erij(1)=xj*rmij
3475           erij(2)=yj*rmij
3476           erij(3)=zj*rmij
3477 !
3478 ! Radial derivatives. First process both termini of the fragment (i,j)
3479 !
3480           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3481           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3482           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3483            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3484           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3485             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3486
3487           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3488           (shield_mode.gt.0)) then
3489 !C          print *,i,j
3490           do ilist=1,ishield_list(i)
3491            iresshield=shield_list(ilist,i)
3492            do k=1,3
3493            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3494            *2.0*sss_ele_cut
3495            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3496                    rlocshield &
3497             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3498             *sss_ele_cut
3499             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3500            enddo
3501           enddo
3502           do ilist=1,ishield_list(j)
3503            iresshield=shield_list(ilist,j)
3504            do k=1,3
3505            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3506           *2.0*sss_ele_cut
3507            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3508                    rlocshield &
3509            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3510            *sss_ele_cut
3511            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3512            enddo
3513           enddo
3514           do k=1,3
3515             gshieldc(k,i)=gshieldc(k,i)+ &
3516                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3517            *sss_ele_cut
3518
3519             gshieldc(k,j)=gshieldc(k,j)+ &
3520                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3521            *sss_ele_cut
3522
3523             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3524                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3525            *sss_ele_cut
3526
3527             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3528                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3529            *sss_ele_cut
3530
3531            enddo
3532            endif
3533
3534
3535 !          do k=1,3
3536 !            ghalf=0.5D0*ggg(k)
3537 !            gelc(k,i)=gelc(k,i)+ghalf
3538 !            gelc(k,j)=gelc(k,j)+ghalf
3539 !          enddo
3540 ! 9/28/08 AL Gradient compotents will be summed only at the end
3541           do k=1,3
3542             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3543             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3544           enddo
3545             gelc_long(3,j)=gelc_long(3,j)+  &
3546           ssgradlipj*eesij/2.0d0*lipscale**2&
3547            *sss_ele_cut
3548
3549             gelc_long(3,i)=gelc_long(3,i)+  &
3550           ssgradlipi*eesij/2.0d0*lipscale**2&
3551            *sss_ele_cut
3552
3553
3554 !
3555 ! Loop over residues i+1 thru j-1.
3556 !
3557 !grad          do k=i+1,j-1
3558 !grad            do l=1,3
3559 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3560 !grad            enddo
3561 !grad          enddo
3562           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3563            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3564           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3565            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3566           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3567            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3568
3569 !          do k=1,3
3570 !            ghalf=0.5D0*ggg(k)
3571 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3572 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3573 !          enddo
3574 ! 9/28/08 AL Gradient compotents will be summed only at the end
3575           do k=1,3
3576             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3577             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3578           enddo
3579
3580 !C Lipidic part for scaling weight
3581            gvdwpp(3,j)=gvdwpp(3,j)+ &
3582           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3583            gvdwpp(3,i)=gvdwpp(3,i)+ &
3584           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3585 !! Loop over residues i+1 thru j-1.
3586 !
3587 !grad          do k=i+1,j-1
3588 !grad            do l=1,3
3589 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3590 !grad            enddo
3591 !grad          enddo
3592 #else
3593           facvdw=(ev1+evdwij)*sss_ele_cut &
3594            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3595
3596           facel=(el1+eesij)*sss_ele_cut
3597           fac1=fac
3598           fac=-3*rrmij*(facvdw+facvdw+facel)
3599           erij(1)=xj*rmij
3600           erij(2)=yj*rmij
3601           erij(3)=zj*rmij
3602 !
3603 ! Radial derivatives. First process both termini of the fragment (i,j)
3604 !
3605           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3606           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3607           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3608 !          do k=1,3
3609 !            ghalf=0.5D0*ggg(k)
3610 !            gelc(k,i)=gelc(k,i)+ghalf
3611 !            gelc(k,j)=gelc(k,j)+ghalf
3612 !          enddo
3613 ! 9/28/08 AL Gradient compotents will be summed only at the end
3614           do k=1,3
3615             gelc_long(k,j)=gelc(k,j)+ggg(k)
3616             gelc_long(k,i)=gelc(k,i)-ggg(k)
3617           enddo
3618 !
3619 ! Loop over residues i+1 thru j-1.
3620 !
3621 !grad          do k=i+1,j-1
3622 !grad            do l=1,3
3623 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3624 !grad            enddo
3625 !grad          enddo
3626 ! 9/28/08 AL Gradient compotents will be summed only at the end
3627           ggg(1)=facvdw*xj &
3628            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3629           ggg(2)=facvdw*yj &
3630            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3631           ggg(3)=facvdw*zj &
3632            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3633
3634           do k=1,3
3635             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3636             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3637           enddo
3638            gvdwpp(3,j)=gvdwpp(3,j)+ &
3639           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3640            gvdwpp(3,i)=gvdwpp(3,i)+ &
3641           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3642
3643 #endif
3644 !
3645 ! Angular part
3646 !
3647           ecosa=2.0D0*fac3*fac1+fac4
3648           fac4=-3.0D0*fac4
3649           fac3=-6.0D0*fac3
3650           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3651           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3652           do k=1,3
3653             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3654             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3655           enddo
3656 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3657 !d   &          (dcosg(k),k=1,3)
3658           do k=1,3
3659             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3660              *fac_shield(i)**2*fac_shield(j)**2 &
3661              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3662
3663           enddo
3664 !          do k=1,3
3665 !            ghalf=0.5D0*ggg(k)
3666 !            gelc(k,i)=gelc(k,i)+ghalf
3667 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3668 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3669 !            gelc(k,j)=gelc(k,j)+ghalf
3670 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3671 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3672 !          enddo
3673 !grad          do k=i+1,j-1
3674 !grad            do l=1,3
3675 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3676 !grad            enddo
3677 !grad          enddo
3678           do k=1,3
3679             gelc(k,i)=gelc(k,i) &
3680                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3681                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3682                      *sss_ele_cut &
3683                      *fac_shield(i)**2*fac_shield(j)**2 &
3684                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3685
3686             gelc(k,j)=gelc(k,j) &
3687                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3688                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3689                      *sss_ele_cut  &
3690                      *fac_shield(i)**2*fac_shield(j)**2  &
3691                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3692
3693             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3694             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3695           enddo
3696
3697           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3698               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3699               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3700 !
3701 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3702 !   energy of a peptide unit is assumed in the form of a second-order
3703 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3704 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3705 !   are computed for EVERY pair of non-contiguous peptide groups.
3706 !
3707           if (j.lt.nres-1) then
3708             j1=j+1
3709             j2=j-1
3710           else
3711             j1=j-1
3712             j2=j-2
3713           endif
3714           kkk=0
3715           do k=1,2
3716             do l=1,2
3717               kkk=kkk+1
3718               muij(kkk)=mu(k,i)*mu(l,j)
3719             enddo
3720           enddo
3721 !d         write (iout,*) 'EELEC: i',i,' j',j
3722 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3723 !d          write(iout,*) 'muij',muij
3724           ury=scalar(uy(1,i),erij)
3725           urz=scalar(uz(1,i),erij)
3726           vry=scalar(uy(1,j),erij)
3727           vrz=scalar(uz(1,j),erij)
3728           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3729           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3730           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3731           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3732           fac=dsqrt(-ael6i)*r3ij
3733           a22=a22*fac
3734           a23=a23*fac
3735           a32=a32*fac
3736           a33=a33*fac
3737 !d          write (iout,'(4i5,4f10.5)')
3738 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3739 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3740 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3741 !d     &      uy(:,j),uz(:,j)
3742 !d          write (iout,'(4f10.5)')
3743 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3744 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3745 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3746 !d           write (iout,'(9f10.5/)')
3747 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3748 ! Derivatives of the elements of A in virtual-bond vectors
3749           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3750           do k=1,3
3751             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3752             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3753             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3754             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3755             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3756             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3757             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3758             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3759             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3760             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3761             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3762             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3763           enddo
3764 ! Compute radial contributions to the gradient
3765           facr=-3.0d0*rrmij
3766           a22der=a22*facr
3767           a23der=a23*facr
3768           a32der=a32*facr
3769           a33der=a33*facr
3770           agg(1,1)=a22der*xj
3771           agg(2,1)=a22der*yj
3772           agg(3,1)=a22der*zj
3773           agg(1,2)=a23der*xj
3774           agg(2,2)=a23der*yj
3775           agg(3,2)=a23der*zj
3776           agg(1,3)=a32der*xj
3777           agg(2,3)=a32der*yj
3778           agg(3,3)=a32der*zj
3779           agg(1,4)=a33der*xj
3780           agg(2,4)=a33der*yj
3781           agg(3,4)=a33der*zj
3782 ! Add the contributions coming from er
3783           fac3=-3.0d0*fac
3784           do k=1,3
3785             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3786             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3787             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3788             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3789           enddo
3790           do k=1,3
3791 ! Derivatives in DC(i)
3792 !grad            ghalf1=0.5d0*agg(k,1)
3793 !grad            ghalf2=0.5d0*agg(k,2)
3794 !grad            ghalf3=0.5d0*agg(k,3)
3795 !grad            ghalf4=0.5d0*agg(k,4)
3796             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3797             -3.0d0*uryg(k,2)*vry)!+ghalf1
3798             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3799             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3800             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3801             -3.0d0*urzg(k,2)*vry)!+ghalf3
3802             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3803             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3804 ! Derivatives in DC(i+1)
3805             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3806             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3807             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3808             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3809             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3810             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3811             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3812             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3813 ! Derivatives in DC(j)
3814             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3815             -3.0d0*vryg(k,2)*ury)!+ghalf1
3816             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3817             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3818             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3819             -3.0d0*vryg(k,2)*urz)!+ghalf3
3820             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3821             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3822 ! Derivatives in DC(j+1) or DC(nres-1)
3823             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3824             -3.0d0*vryg(k,3)*ury)
3825             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3826             -3.0d0*vrzg(k,3)*ury)
3827             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3828             -3.0d0*vryg(k,3)*urz)
3829             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3830             -3.0d0*vrzg(k,3)*urz)
3831 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3832 !grad              do l=1,4
3833 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3834 !grad              enddo
3835 !grad            endif
3836           enddo
3837           acipa(1,1)=a22
3838           acipa(1,2)=a23
3839           acipa(2,1)=a32
3840           acipa(2,2)=a33
3841           a22=-a22
3842           a23=-a23
3843           do l=1,2
3844             do k=1,3
3845               agg(k,l)=-agg(k,l)
3846               aggi(k,l)=-aggi(k,l)
3847               aggi1(k,l)=-aggi1(k,l)
3848               aggj(k,l)=-aggj(k,l)
3849               aggj1(k,l)=-aggj1(k,l)
3850             enddo
3851           enddo
3852           if (j.lt.nres-1) then
3853             a22=-a22
3854             a32=-a32
3855             do l=1,3,2
3856               do k=1,3
3857                 agg(k,l)=-agg(k,l)
3858                 aggi(k,l)=-aggi(k,l)
3859                 aggi1(k,l)=-aggi1(k,l)
3860                 aggj(k,l)=-aggj(k,l)
3861                 aggj1(k,l)=-aggj1(k,l)
3862               enddo
3863             enddo
3864           else
3865             a22=-a22
3866             a23=-a23
3867             a32=-a32
3868             a33=-a33
3869             do l=1,4
3870               do k=1,3
3871                 agg(k,l)=-agg(k,l)
3872                 aggi(k,l)=-aggi(k,l)
3873                 aggi1(k,l)=-aggi1(k,l)
3874                 aggj(k,l)=-aggj(k,l)
3875                 aggj1(k,l)=-aggj1(k,l)
3876               enddo
3877             enddo
3878           endif
3879           ENDIF ! WCORR
3880           IF (wel_loc.gt.0.0d0) THEN
3881 ! Contribution to the local-electrostatic energy coming from the i-j pair
3882           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3883            +a33*muij(4)
3884           if (shield_mode.eq.0) then
3885            fac_shield(i)=1.0
3886            fac_shield(j)=1.0
3887           endif
3888           eel_loc_ij=eel_loc_ij &
3889          *fac_shield(i)*fac_shield(j) &
3890          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3891 !C Now derivative over eel_loc
3892           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3893          (shield_mode.gt.0)) then
3894 !C          print *,i,j
3895
3896           do ilist=1,ishield_list(i)
3897            iresshield=shield_list(ilist,i)
3898            do k=1,3
3899            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3900                                                 /fac_shield(i)&
3901            *sss_ele_cut
3902            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3903                    rlocshield  &
3904           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3905           *sss_ele_cut
3906
3907             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3908            +rlocshield
3909            enddo
3910           enddo
3911           do ilist=1,ishield_list(j)
3912            iresshield=shield_list(ilist,j)
3913            do k=1,3
3914            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3915                                             /fac_shield(j)   &
3916             *sss_ele_cut
3917            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3918                    rlocshield  &
3919       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3920        *sss_ele_cut
3921
3922            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3923                   +rlocshield
3924
3925            enddo
3926           enddo
3927
3928           do k=1,3
3929             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3930                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3931                     *sss_ele_cut
3932             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3933                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3934                     *sss_ele_cut
3935             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3936                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3937                     *sss_ele_cut
3938             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3939                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3940                     *sss_ele_cut
3941
3942            enddo
3943            endif
3944
3945
3946 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3947 !           eel_loc_ij=0.0
3948           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3949                   'eelloc',i,j,eel_loc_ij
3950 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3951 !          if (energy_dec) write (iout,*) "muij",muij
3952 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3953
3954           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3955 ! Partial derivatives in virtual-bond dihedral angles gamma
3956           if (i.gt.1) &
3957           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3958                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3959                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3960                  *sss_ele_cut  &
3961           *fac_shield(i)*fac_shield(j) &
3962           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3963
3964           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3965                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3966                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3967                  *sss_ele_cut &
3968           *fac_shield(i)*fac_shield(j) &
3969           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3970 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3971 !          do l=1,3
3972 !            ggg(1)=(agg(1,1)*muij(1)+ &
3973 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3974 !            *sss_ele_cut &
3975 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3976 !            ggg(2)=(agg(2,1)*muij(1)+ &
3977 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3978 !            *sss_ele_cut &
3979 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3980 !            ggg(3)=(agg(3,1)*muij(1)+ &
3981 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3982 !            *sss_ele_cut &
3983 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3984            xtemp(1)=xj
3985            xtemp(2)=yj
3986            xtemp(3)=zj
3987
3988            do l=1,3
3989             ggg(l)=(agg(l,1)*muij(1)+ &
3990                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3991             *sss_ele_cut &
3992           *fac_shield(i)*fac_shield(j) &
3993           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3994              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3995
3996
3997             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3998             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3999 !grad            ghalf=0.5d0*ggg(l)
4000 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4001 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4002           enddo
4003             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4004           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4005           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4006
4007             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4008           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4009           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4010
4011 !grad          do k=i+1,j2
4012 !grad            do l=1,3
4013 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4014 !grad            enddo
4015 !grad          enddo
4016 ! Remaining derivatives of eello
4017           do l=1,3
4018             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4019                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4020             *sss_ele_cut &
4021           *fac_shield(i)*fac_shield(j) &
4022           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4023
4024 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4025             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4026                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4027             +aggi1(l,4)*muij(4))&
4028             *sss_ele_cut &
4029           *fac_shield(i)*fac_shield(j) &
4030           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4031
4032 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4033             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4034                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4035             *sss_ele_cut &
4036           *fac_shield(i)*fac_shield(j) &
4037           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4038
4039 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4040             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4041                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4042             +aggj1(l,4)*muij(4))&
4043             *sss_ele_cut &
4044           *fac_shield(i)*fac_shield(j) &
4045           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4046
4047 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4048           enddo
4049           ENDIF
4050 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4051 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4052           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4053              .and. num_conti.le.maxconts) then
4054 !            write (iout,*) i,j," entered corr"
4055 !
4056 ! Calculate the contact function. The ith column of the array JCONT will
4057 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4058 ! greater than I). The arrays FACONT and GACONT will contain the values of
4059 ! the contact function and its derivative.
4060 !           r0ij=1.02D0*rpp(iteli,itelj)
4061 !           r0ij=1.11D0*rpp(iteli,itelj)
4062             r0ij=2.20D0*rpp(iteli,itelj)
4063 !           r0ij=1.55D0*rpp(iteli,itelj)
4064             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4065 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4066             if (fcont.gt.0.0D0) then
4067               num_conti=num_conti+1
4068               if (num_conti.gt.maxconts) then
4069 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4070 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4071                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4072                                ' will skip next contacts for this conf.', num_conti
4073               else
4074                 jcont_hb(num_conti,i)=j
4075 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4076 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4077                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4078                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4079 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4080 !  terms.
4081                 d_cont(num_conti,i)=rij
4082 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4083 !     --- Electrostatic-interaction matrix ---
4084                 a_chuj(1,1,num_conti,i)=a22
4085                 a_chuj(1,2,num_conti,i)=a23
4086                 a_chuj(2,1,num_conti,i)=a32
4087                 a_chuj(2,2,num_conti,i)=a33
4088 !     --- Gradient of rij
4089                 do kkk=1,3
4090                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4091                 enddo
4092                 kkll=0
4093                 do k=1,2
4094                   do l=1,2
4095                     kkll=kkll+1
4096                     do m=1,3
4097                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4098                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4099                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4100                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4101                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4102                     enddo
4103                   enddo
4104                 enddo
4105                 ENDIF
4106                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4107 ! Calculate contact energies
4108                 cosa4=4.0D0*cosa
4109                 wij=cosa-3.0D0*cosb*cosg
4110                 cosbg1=cosb+cosg
4111                 cosbg2=cosb-cosg
4112 !               fac3=dsqrt(-ael6i)/r0ij**3
4113                 fac3=dsqrt(-ael6i)*r3ij
4114 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4115                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4116                 if (ees0tmp.gt.0) then
4117                   ees0pij=dsqrt(ees0tmp)
4118                 else
4119                   ees0pij=0
4120                 endif
4121                 if (shield_mode.eq.0) then
4122                 fac_shield(i)=1.0d0
4123                 fac_shield(j)=1.0d0
4124                 else
4125                 ees0plist(num_conti,i)=j
4126                 endif
4127 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4128                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4129                 if (ees0tmp.gt.0) then
4130                   ees0mij=dsqrt(ees0tmp)
4131                 else
4132                   ees0mij=0
4133                 endif
4134 !               ees0mij=0.0D0
4135                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4136                      *sss_ele_cut &
4137                      *fac_shield(i)*fac_shield(j)
4138
4139                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4140                      *sss_ele_cut &
4141                      *fac_shield(i)*fac_shield(j)
4142
4143 ! Diagnostics. Comment out or remove after debugging!
4144 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4145 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4146 !               ees0m(num_conti,i)=0.0D0
4147 ! End diagnostics.
4148 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4149 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4150 ! Angular derivatives of the contact function
4151                 ees0pij1=fac3/ees0pij
4152                 ees0mij1=fac3/ees0mij
4153                 fac3p=-3.0D0*fac3*rrmij
4154                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4155                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4156 !               ees0mij1=0.0D0
4157                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4158                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4159                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4160                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4161                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4162                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4163                 ecosap=ecosa1+ecosa2
4164                 ecosbp=ecosb1+ecosb2
4165                 ecosgp=ecosg1+ecosg2
4166                 ecosam=ecosa1-ecosa2
4167                 ecosbm=ecosb1-ecosb2
4168                 ecosgm=ecosg1-ecosg2
4169 ! Diagnostics
4170 !               ecosap=ecosa1
4171 !               ecosbp=ecosb1
4172 !               ecosgp=ecosg1
4173 !               ecosam=0.0D0
4174 !               ecosbm=0.0D0
4175 !               ecosgm=0.0D0
4176 ! End diagnostics
4177                 facont_hb(num_conti,i)=fcont
4178                 fprimcont=fprimcont/rij
4179 !d              facont_hb(num_conti,i)=1.0D0
4180 ! Following line is for diagnostics.
4181 !d              fprimcont=0.0D0
4182                 do k=1,3
4183                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4184                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4185                 enddo
4186                 do k=1,3
4187                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4188                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4189                 enddo
4190                 gggp(1)=gggp(1)+ees0pijp*xj &
4191                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4192                 gggp(2)=gggp(2)+ees0pijp*yj &
4193                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4194                 gggp(3)=gggp(3)+ees0pijp*zj &
4195                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4196
4197                 gggm(1)=gggm(1)+ees0mijp*xj &
4198                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4199
4200                 gggm(2)=gggm(2)+ees0mijp*yj &
4201                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4202
4203                 gggm(3)=gggm(3)+ees0mijp*zj &
4204                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4205
4206 ! Derivatives due to the contact function
4207                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4208                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4209                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4210                 do k=1,3
4211 !
4212 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4213 !          following the change of gradient-summation algorithm.
4214 !
4215 !grad                  ghalfp=0.5D0*gggp(k)
4216 !grad                  ghalfm=0.5D0*gggm(k)
4217                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4218                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4219                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4220                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4221
4222                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4223                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4224                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4225                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4226
4227                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4228                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4229
4230                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4231                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4232                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4233                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4234
4235                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4236                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4237                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4238                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4239
4240                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4241                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4242
4243                 enddo
4244 ! Diagnostics. Comment out or remove after debugging!
4245 !diag           do k=1,3
4246 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4247 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4248 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4249 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4250 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4251 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4252 !diag           enddo
4253               ENDIF ! wcorr
4254               endif  ! num_conti.le.maxconts
4255             endif  ! fcont.gt.0
4256           endif    ! j.gt.i+1
4257           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4258             do k=1,4
4259               do l=1,3
4260                 ghalf=0.5d0*agg(l,k)
4261                 aggi(l,k)=aggi(l,k)+ghalf
4262                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4263                 aggj(l,k)=aggj(l,k)+ghalf
4264               enddo
4265             enddo
4266             if (j.eq.nres-1 .and. i.lt.j-2) then
4267               do k=1,4
4268                 do l=1,3
4269                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4270                 enddo
4271               enddo
4272             endif
4273           endif
4274  128  continue
4275 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4276       return
4277       end subroutine eelecij
4278 !-----------------------------------------------------------------------------
4279       subroutine eturn3(i,eello_turn3)
4280 ! Third- and fourth-order contributions from turns
4281
4282       use comm_locel
4283 !      implicit real*8 (a-h,o-z)
4284 !      include 'DIMENSIONS'
4285 !      include 'COMMON.IOUNITS'
4286 !      include 'COMMON.GEO'
4287 !      include 'COMMON.VAR'
4288 !      include 'COMMON.LOCAL'
4289 !      include 'COMMON.CHAIN'
4290 !      include 'COMMON.DERIV'
4291 !      include 'COMMON.INTERACT'
4292 !      include 'COMMON.CONTACTS'
4293 !      include 'COMMON.TORSION'
4294 !      include 'COMMON.VECTORS'
4295 !      include 'COMMON.FFIELD'
4296 !      include 'COMMON.CONTROL'
4297       real(kind=8),dimension(3) :: ggg
4298       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4299         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4300       real(kind=8),dimension(2) :: auxvec,auxvec1
4301 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4302       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4303 !el      integer :: num_conti,j1,j2
4304 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4305 !el        dz_normi,xmedi,ymedi,zmedi
4306
4307 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4308 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4309 !el         num_conti,j1,j2
4310 !el local variables
4311       integer :: i,j,l,k,ilist,iresshield
4312       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4313
4314       j=i+2
4315 !      write (iout,*) "eturn3",i,j,j1,j2
4316           zj=(c(3,j)+c(3,j+1))/2.0d0
4317           zj=mod(zj,boxzsize)
4318           if (zj.lt.0) zj=zj+boxzsize
4319           if ((zj.lt.0)) write (*,*) "CHUJ"
4320        if ((zj.gt.bordlipbot)  &
4321         .and.(zj.lt.bordliptop)) then
4322 !C the energy transfer exist
4323         if (zj.lt.buflipbot) then
4324 !C what fraction I am in
4325          fracinbuf=1.0d0-     &
4326              ((zj-bordlipbot)/lipbufthick)
4327 !C lipbufthick is thickenes of lipid buffore
4328          sslipj=sscalelip(fracinbuf)
4329          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4330         elseif (zj.gt.bufliptop) then
4331          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4332          sslipj=sscalelip(fracinbuf)
4333          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4334         else
4335          sslipj=1.0d0
4336          ssgradlipj=0.0
4337         endif
4338        else
4339          sslipj=0.0d0
4340          ssgradlipj=0.0
4341        endif
4342
4343       a_temp(1,1)=a22
4344       a_temp(1,2)=a23
4345       a_temp(2,1)=a32
4346       a_temp(2,2)=a33
4347 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4348 !
4349 !               Third-order contributions
4350 !
4351 !                 (i+2)o----(i+3)
4352 !                      | |
4353 !                      | |
4354 !                 (i+1)o----i
4355 !
4356 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4357 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4358         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4359         call transpose2(auxmat(1,1),auxmat1(1,1))
4360         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4361         if (shield_mode.eq.0) then
4362         fac_shield(i)=1.0d0
4363         fac_shield(j)=1.0d0
4364         endif
4365
4366         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4367          *fac_shield(i)*fac_shield(j)  &
4368          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4369         eello_t3= &
4370         0.5d0*(pizda(1,1)+pizda(2,2)) &
4371         *fac_shield(i)*fac_shield(j)
4372
4373         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4374                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4375           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4376        (shield_mode.gt.0)) then
4377 !C          print *,i,j
4378
4379           do ilist=1,ishield_list(i)
4380            iresshield=shield_list(ilist,i)
4381            do k=1,3
4382            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4383            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4384                    rlocshield &
4385            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4386             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4387              +rlocshield
4388            enddo
4389           enddo
4390           do ilist=1,ishield_list(j)
4391            iresshield=shield_list(ilist,j)
4392            do k=1,3
4393            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4394            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4395                    rlocshield &
4396            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4397            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4398                   +rlocshield
4399
4400            enddo
4401           enddo
4402
4403           do k=1,3
4404             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4405                    grad_shield(k,i)*eello_t3/fac_shield(i)
4406             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4407                    grad_shield(k,j)*eello_t3/fac_shield(j)
4408             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4409                    grad_shield(k,i)*eello_t3/fac_shield(i)
4410             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4411                    grad_shield(k,j)*eello_t3/fac_shield(j)
4412            enddo
4413            endif
4414
4415 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4416 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4417 !d     &    ' eello_turn3_num',4*eello_turn3_num
4418 ! Derivatives in gamma(i)
4419         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4420         call transpose2(auxmat2(1,1),auxmat3(1,1))
4421         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4422         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4423           *fac_shield(i)*fac_shield(j)        &
4424           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4425 ! Derivatives in gamma(i+1)
4426         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4427         call transpose2(auxmat2(1,1),auxmat3(1,1))
4428         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4429         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4430           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4431           *fac_shield(i)*fac_shield(j)        &
4432           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4433
4434 ! Cartesian derivatives
4435         do l=1,3
4436 !            ghalf1=0.5d0*agg(l,1)
4437 !            ghalf2=0.5d0*agg(l,2)
4438 !            ghalf3=0.5d0*agg(l,3)
4439 !            ghalf4=0.5d0*agg(l,4)
4440           a_temp(1,1)=aggi(l,1)!+ghalf1
4441           a_temp(1,2)=aggi(l,2)!+ghalf2
4442           a_temp(2,1)=aggi(l,3)!+ghalf3
4443           a_temp(2,2)=aggi(l,4)!+ghalf4
4444           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4445           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4446             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4447           *fac_shield(i)*fac_shield(j)      &
4448           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4449
4450           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4451           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4452           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4453           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4454           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4455           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4456             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4457           *fac_shield(i)*fac_shield(j)        &
4458           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4459
4460           a_temp(1,1)=aggj(l,1)!+ghalf1
4461           a_temp(1,2)=aggj(l,2)!+ghalf2
4462           a_temp(2,1)=aggj(l,3)!+ghalf3
4463           a_temp(2,2)=aggj(l,4)!+ghalf4
4464           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4465           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4466             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4467           *fac_shield(i)*fac_shield(j)      &
4468           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4469
4470           a_temp(1,1)=aggj1(l,1)
4471           a_temp(1,2)=aggj1(l,2)
4472           a_temp(2,1)=aggj1(l,3)
4473           a_temp(2,2)=aggj1(l,4)
4474           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4475           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4476             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4477           *fac_shield(i)*fac_shield(j)        &
4478           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4479         enddo
4480          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4481           ssgradlipi*eello_t3/4.0d0*lipscale
4482          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4483           ssgradlipj*eello_t3/4.0d0*lipscale
4484          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4485           ssgradlipi*eello_t3/4.0d0*lipscale
4486          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4487           ssgradlipj*eello_t3/4.0d0*lipscale
4488
4489       return
4490       end subroutine eturn3
4491 !-----------------------------------------------------------------------------
4492       subroutine eturn4(i,eello_turn4)
4493 ! Third- and fourth-order contributions from turns
4494
4495       use comm_locel
4496 !      implicit real*8 (a-h,o-z)
4497 !      include 'DIMENSIONS'
4498 !      include 'COMMON.IOUNITS'
4499 !      include 'COMMON.GEO'
4500 !      include 'COMMON.VAR'
4501 !      include 'COMMON.LOCAL'
4502 !      include 'COMMON.CHAIN'
4503 !      include 'COMMON.DERIV'
4504 !      include 'COMMON.INTERACT'
4505 !      include 'COMMON.CONTACTS'
4506 !      include 'COMMON.TORSION'
4507 !      include 'COMMON.VECTORS'
4508 !      include 'COMMON.FFIELD'
4509 !      include 'COMMON.CONTROL'
4510       real(kind=8),dimension(3) :: ggg
4511       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4512         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4513       real(kind=8),dimension(2) :: auxvec,auxvec1
4514 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4515       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4516 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4517 !el        dz_normi,xmedi,ymedi,zmedi
4518 !el      integer :: num_conti,j1,j2
4519 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4520 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4521 !el          num_conti,j1,j2
4522 !el local variables
4523       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4524       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4525          rlocshield
4526
4527       j=i+3
4528 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4529 !
4530 !               Fourth-order contributions
4531 !
4532 !                 (i+3)o----(i+4)
4533 !                     /  |
4534 !               (i+2)o   |
4535 !                     \  |
4536 !                 (i+1)o----i
4537 !
4538 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4539 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4540 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4541           zj=(c(3,j)+c(3,j+1))/2.0d0
4542           zj=mod(zj,boxzsize)
4543           if (zj.lt.0) zj=zj+boxzsize
4544        if ((zj.gt.bordlipbot)  &
4545         .and.(zj.lt.bordliptop)) then
4546 !C the energy transfer exist
4547         if (zj.lt.buflipbot) then
4548 !C what fraction I am in
4549          fracinbuf=1.0d0-     &
4550              ((zj-bordlipbot)/lipbufthick)
4551 !C lipbufthick is thickenes of lipid buffore
4552          sslipj=sscalelip(fracinbuf)
4553          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4554         elseif (zj.gt.bufliptop) then
4555          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4556          sslipj=sscalelip(fracinbuf)
4557          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4558         else
4559          sslipj=1.0d0
4560          ssgradlipj=0.0
4561         endif
4562        else
4563          sslipj=0.0d0
4564          ssgradlipj=0.0
4565        endif
4566
4567         a_temp(1,1)=a22
4568         a_temp(1,2)=a23
4569         a_temp(2,1)=a32
4570         a_temp(2,2)=a33
4571         iti1=itortyp(itype(i+1,1))
4572         iti2=itortyp(itype(i+2,1))
4573         iti3=itortyp(itype(i+3,1))
4574 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4575         call transpose2(EUg(1,1,i+1),e1t(1,1))
4576         call transpose2(Eug(1,1,i+2),e2t(1,1))
4577         call transpose2(Eug(1,1,i+3),e3t(1,1))
4578         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4579         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4580         s1=scalar2(b1(1,iti2),auxvec(1))
4581         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4582         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4583         s2=scalar2(b1(1,iti1),auxvec(1))
4584         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4585         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4586         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4587         if (shield_mode.eq.0) then
4588         fac_shield(i)=1.0
4589         fac_shield(j)=1.0
4590         endif
4591
4592         eello_turn4=eello_turn4-(s1+s2+s3) &
4593         *fac_shield(i)*fac_shield(j)       &
4594         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4595         eello_t4=-(s1+s2+s3)  &
4596           *fac_shield(i)*fac_shield(j)
4597 !C Now derivative over shield:
4598           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4599          (shield_mode.gt.0)) then
4600 !C          print *,i,j
4601
4602           do ilist=1,ishield_list(i)
4603            iresshield=shield_list(ilist,i)
4604            do k=1,3
4605            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4606            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4607                    rlocshield &
4608             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4609             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4610            +rlocshield
4611            enddo
4612           enddo
4613           do ilist=1,ishield_list(j)
4614            iresshield=shield_list(ilist,j)
4615            do k=1,3
4616            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4617            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4618                    rlocshield  &
4619            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4620            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4621                   +rlocshield
4622
4623            enddo
4624           enddo
4625
4626           do k=1,3
4627             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4628                    grad_shield(k,i)*eello_t4/fac_shield(i)
4629             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4630                    grad_shield(k,j)*eello_t4/fac_shield(j)
4631             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4632                    grad_shield(k,i)*eello_t4/fac_shield(i)
4633             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4634                    grad_shield(k,j)*eello_t4/fac_shield(j)
4635            enddo
4636            endif
4637
4638         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4639            'eturn4',i,j,-(s1+s2+s3)
4640 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4641 !d     &    ' eello_turn4_num',8*eello_turn4_num
4642 ! Derivatives in gamma(i)
4643         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4644         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4645         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4646         s1=scalar2(b1(1,iti2),auxvec(1))
4647         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4648         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4649         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4650        *fac_shield(i)*fac_shield(j)  &
4651        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4652
4653 ! Derivatives in gamma(i+1)
4654         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4655         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4656         s2=scalar2(b1(1,iti1),auxvec(1))
4657         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4658         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4659         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4660         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4661        *fac_shield(i)*fac_shield(j)  &
4662        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4663
4664 ! Derivatives in gamma(i+2)
4665         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4666         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4667         s1=scalar2(b1(1,iti2),auxvec(1))
4668         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4669         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4670         s2=scalar2(b1(1,iti1),auxvec(1))
4671         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4672         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4673         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4674         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4675        *fac_shield(i)*fac_shield(j)  &
4676        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4677
4678 ! Cartesian derivatives
4679 ! Derivatives of this turn contributions in DC(i+2)
4680         if (j.lt.nres-1) then
4681           do l=1,3
4682             a_temp(1,1)=agg(l,1)
4683             a_temp(1,2)=agg(l,2)
4684             a_temp(2,1)=agg(l,3)
4685             a_temp(2,2)=agg(l,4)
4686             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4687             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4688             s1=scalar2(b1(1,iti2),auxvec(1))
4689             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4690             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4691             s2=scalar2(b1(1,iti1),auxvec(1))
4692             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4693             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4694             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4695             ggg(l)=-(s1+s2+s3)
4696             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4697        *fac_shield(i)*fac_shield(j)  &
4698        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4699
4700           enddo
4701         endif
4702 ! Remaining derivatives of this turn contribution
4703         do l=1,3
4704           a_temp(1,1)=aggi(l,1)
4705           a_temp(1,2)=aggi(l,2)
4706           a_temp(2,1)=aggi(l,3)
4707           a_temp(2,2)=aggi(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           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4718          *fac_shield(i)*fac_shield(j)  &
4719          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4720
4721
4722           a_temp(1,1)=aggi1(l,1)
4723           a_temp(1,2)=aggi1(l,2)
4724           a_temp(2,1)=aggi1(l,3)
4725           a_temp(2,2)=aggi1(l,4)
4726           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4727           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4728           s1=scalar2(b1(1,iti2),auxvec(1))
4729           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4730           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4731           s2=scalar2(b1(1,iti1),auxvec(1))
4732           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4733           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4734           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4735           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4736          *fac_shield(i)*fac_shield(j)  &
4737          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4738
4739
4740           a_temp(1,1)=aggj(l,1)
4741           a_temp(1,2)=aggj(l,2)
4742           a_temp(2,1)=aggj(l,3)
4743           a_temp(2,2)=aggj(l,4)
4744           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4745           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4746           s1=scalar2(b1(1,iti2),auxvec(1))
4747           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4748           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4749           s2=scalar2(b1(1,iti1),auxvec(1))
4750           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4751           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4752           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4753           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4754          *fac_shield(i)*fac_shield(j)  &
4755          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4756
4757
4758           a_temp(1,1)=aggj1(l,1)
4759           a_temp(1,2)=aggj1(l,2)
4760           a_temp(2,1)=aggj1(l,3)
4761           a_temp(2,2)=aggj1(l,4)
4762           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4763           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4764           s1=scalar2(b1(1,iti2),auxvec(1))
4765           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4766           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4767           s2=scalar2(b1(1,iti1),auxvec(1))
4768           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4769           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4770           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4771 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4772           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4773          *fac_shield(i)*fac_shield(j)  &
4774          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4775
4776         enddo
4777          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4778           ssgradlipi*eello_t4/4.0d0*lipscale
4779          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4780           ssgradlipj*eello_t4/4.0d0*lipscale
4781          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4782           ssgradlipi*eello_t4/4.0d0*lipscale
4783          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4784           ssgradlipj*eello_t4/4.0d0*lipscale
4785
4786       return
4787       end subroutine eturn4
4788 !-----------------------------------------------------------------------------
4789       subroutine unormderiv(u,ugrad,unorm,ungrad)
4790 ! This subroutine computes the derivatives of a normalized vector u, given
4791 ! the derivatives computed without normalization conditions, ugrad. Returns
4792 ! ungrad.
4793 !      implicit none
4794       real(kind=8),dimension(3) :: u,vec
4795       real(kind=8),dimension(3,3) ::ugrad,ungrad
4796       real(kind=8) :: unorm      !,scalar
4797       integer :: i,j
4798 !      write (2,*) 'ugrad',ugrad
4799 !      write (2,*) 'u',u
4800       do i=1,3
4801         vec(i)=scalar(ugrad(1,i),u(1))
4802       enddo
4803 !      write (2,*) 'vec',vec
4804       do i=1,3
4805         do j=1,3
4806           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4807         enddo
4808       enddo
4809 !      write (2,*) 'ungrad',ungrad
4810       return
4811       end subroutine unormderiv
4812 !-----------------------------------------------------------------------------
4813       subroutine escp_soft_sphere(evdw2,evdw2_14)
4814 !
4815 ! This subroutine calculates the excluded-volume interaction energy between
4816 ! peptide-group centers and side chains and its gradient in virtual-bond and
4817 ! side-chain vectors.
4818 !
4819 !      implicit real*8 (a-h,o-z)
4820 !      include 'DIMENSIONS'
4821 !      include 'COMMON.GEO'
4822 !      include 'COMMON.VAR'
4823 !      include 'COMMON.LOCAL'
4824 !      include 'COMMON.CHAIN'
4825 !      include 'COMMON.DERIV'
4826 !      include 'COMMON.INTERACT'
4827 !      include 'COMMON.FFIELD'
4828 !      include 'COMMON.IOUNITS'
4829 !      include 'COMMON.CONTROL'
4830       real(kind=8),dimension(3) :: ggg
4831 !el local variables
4832       integer :: i,iint,j,k,iteli,itypj
4833       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4834                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4835
4836       evdw2=0.0D0
4837       evdw2_14=0.0d0
4838       r0_scp=4.5d0
4839 !d    print '(a)','Enter ESCP'
4840 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4841       do i=iatscp_s,iatscp_e
4842         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4843         iteli=itel(i)
4844         xi=0.5D0*(c(1,i)+c(1,i+1))
4845         yi=0.5D0*(c(2,i)+c(2,i+1))
4846         zi=0.5D0*(c(3,i)+c(3,i+1))
4847
4848         do iint=1,nscp_gr(i)
4849
4850         do j=iscpstart(i,iint),iscpend(i,iint)
4851           if (itype(j,1).eq.ntyp1) cycle
4852           itypj=iabs(itype(j,1))
4853 ! Uncomment following three lines for SC-p interactions
4854 !         xj=c(1,nres+j)-xi
4855 !         yj=c(2,nres+j)-yi
4856 !         zj=c(3,nres+j)-zi
4857 ! Uncomment following three lines for Ca-p interactions
4858           xj=c(1,j)-xi
4859           yj=c(2,j)-yi
4860           zj=c(3,j)-zi
4861           rij=xj*xj+yj*yj+zj*zj
4862           r0ij=r0_scp
4863           r0ijsq=r0ij*r0ij
4864           if (rij.lt.r0ijsq) then
4865             evdwij=0.25d0*(rij-r0ijsq)**2
4866             fac=rij-r0ijsq
4867           else
4868             evdwij=0.0d0
4869             fac=0.0d0
4870           endif
4871           evdw2=evdw2+evdwij
4872 !
4873 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4874 !
4875           ggg(1)=xj*fac
4876           ggg(2)=yj*fac
4877           ggg(3)=zj*fac
4878 !grad          if (j.lt.i) then
4879 !d          write (iout,*) 'j<i'
4880 ! Uncomment following three lines for SC-p interactions
4881 !           do k=1,3
4882 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4883 !           enddo
4884 !grad          else
4885 !d          write (iout,*) 'j>i'
4886 !grad            do k=1,3
4887 !grad              ggg(k)=-ggg(k)
4888 ! Uncomment following line for SC-p interactions
4889 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4890 !grad            enddo
4891 !grad          endif
4892 !grad          do k=1,3
4893 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4894 !grad          enddo
4895 !grad          kstart=min0(i+1,j)
4896 !grad          kend=max0(i-1,j-1)
4897 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4898 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4899 !grad          do k=kstart,kend
4900 !grad            do l=1,3
4901 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4902 !grad            enddo
4903 !grad          enddo
4904           do k=1,3
4905             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4906             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4907           enddo
4908         enddo
4909
4910         enddo ! iint
4911       enddo ! i
4912       return
4913       end subroutine escp_soft_sphere
4914 !-----------------------------------------------------------------------------
4915       subroutine escp(evdw2,evdw2_14)
4916 !
4917 ! This subroutine calculates the excluded-volume interaction energy between
4918 ! peptide-group centers and side chains and its gradient in virtual-bond and
4919 ! side-chain vectors.
4920 !
4921 !      implicit real*8 (a-h,o-z)
4922 !      include 'DIMENSIONS'
4923 !      include 'COMMON.GEO'
4924 !      include 'COMMON.VAR'
4925 !      include 'COMMON.LOCAL'
4926 !      include 'COMMON.CHAIN'
4927 !      include 'COMMON.DERIV'
4928 !      include 'COMMON.INTERACT'
4929 !      include 'COMMON.FFIELD'
4930 !      include 'COMMON.IOUNITS'
4931 !      include 'COMMON.CONTROL'
4932       real(kind=8),dimension(3) :: ggg
4933 !el local variables
4934       integer :: i,iint,j,k,iteli,itypj,subchap
4935       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4936                    e1,e2,evdwij,rij
4937       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4938                     dist_temp, dist_init
4939       integer xshift,yshift,zshift
4940
4941       evdw2=0.0D0
4942       evdw2_14=0.0d0
4943 !d    print '(a)','Enter ESCP'
4944 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4945       do i=iatscp_s,iatscp_e
4946         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4947         iteli=itel(i)
4948         xi=0.5D0*(c(1,i)+c(1,i+1))
4949         yi=0.5D0*(c(2,i)+c(2,i+1))
4950         zi=0.5D0*(c(3,i)+c(3,i+1))
4951           xi=mod(xi,boxxsize)
4952           if (xi.lt.0) xi=xi+boxxsize
4953           yi=mod(yi,boxysize)
4954           if (yi.lt.0) yi=yi+boxysize
4955           zi=mod(zi,boxzsize)
4956           if (zi.lt.0) zi=zi+boxzsize
4957
4958         do iint=1,nscp_gr(i)
4959
4960         do j=iscpstart(i,iint),iscpend(i,iint)
4961           itypj=iabs(itype(j,1))
4962           if (itypj.eq.ntyp1) cycle
4963 ! Uncomment following three lines for SC-p interactions
4964 !         xj=c(1,nres+j)-xi
4965 !         yj=c(2,nres+j)-yi
4966 !         zj=c(3,nres+j)-zi
4967 ! Uncomment following three lines for Ca-p interactions
4968 !          xj=c(1,j)-xi
4969 !          yj=c(2,j)-yi
4970 !          zj=c(3,j)-zi
4971           xj=c(1,j)
4972           yj=c(2,j)
4973           zj=c(3,j)
4974           xj=mod(xj,boxxsize)
4975           if (xj.lt.0) xj=xj+boxxsize
4976           yj=mod(yj,boxysize)
4977           if (yj.lt.0) yj=yj+boxysize
4978           zj=mod(zj,boxzsize)
4979           if (zj.lt.0) zj=zj+boxzsize
4980       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4981       xj_safe=xj
4982       yj_safe=yj
4983       zj_safe=zj
4984       subchap=0
4985       do xshift=-1,1
4986       do yshift=-1,1
4987       do zshift=-1,1
4988           xj=xj_safe+xshift*boxxsize
4989           yj=yj_safe+yshift*boxysize
4990           zj=zj_safe+zshift*boxzsize
4991           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4992           if(dist_temp.lt.dist_init) then
4993             dist_init=dist_temp
4994             xj_temp=xj
4995             yj_temp=yj
4996             zj_temp=zj
4997             subchap=1
4998           endif
4999        enddo
5000        enddo
5001        enddo
5002        if (subchap.eq.1) then
5003           xj=xj_temp-xi
5004           yj=yj_temp-yi
5005           zj=zj_temp-zi
5006        else
5007           xj=xj_safe-xi
5008           yj=yj_safe-yi
5009           zj=zj_safe-zi
5010        endif
5011
5012           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5013           rij=dsqrt(1.0d0/rrij)
5014             sss_ele_cut=sscale_ele(rij)
5015             sss_ele_grad=sscagrad_ele(rij)
5016 !            print *,sss_ele_cut,sss_ele_grad,&
5017 !            (rij),r_cut_ele,rlamb_ele
5018             if (sss_ele_cut.le.0.0) cycle
5019           fac=rrij**expon2
5020           e1=fac*fac*aad(itypj,iteli)
5021           e2=fac*bad(itypj,iteli)
5022           if (iabs(j-i) .le. 2) then
5023             e1=scal14*e1
5024             e2=scal14*e2
5025             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5026           endif
5027           evdwij=e1+e2
5028           evdw2=evdw2+evdwij*sss_ele_cut
5029 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5030 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5031           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5032              'evdw2',i,j,evdwij
5033 !
5034 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5035 !
5036           fac=-(evdwij+e1)*rrij*sss_ele_cut
5037           fac=fac+evdwij*sss_ele_grad/rij/expon
5038           ggg(1)=xj*fac
5039           ggg(2)=yj*fac
5040           ggg(3)=zj*fac
5041 !grad          if (j.lt.i) then
5042 !d          write (iout,*) 'j<i'
5043 ! Uncomment following three lines for SC-p interactions
5044 !           do k=1,3
5045 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5046 !           enddo
5047 !grad          else
5048 !d          write (iout,*) 'j>i'
5049 !grad            do k=1,3
5050 !grad              ggg(k)=-ggg(k)
5051 ! Uncomment following line for SC-p interactions
5052 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5053 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5054 !grad            enddo
5055 !grad          endif
5056 !grad          do k=1,3
5057 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5058 !grad          enddo
5059 !grad          kstart=min0(i+1,j)
5060 !grad          kend=max0(i-1,j-1)
5061 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5062 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5063 !grad          do k=kstart,kend
5064 !grad            do l=1,3
5065 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5066 !grad            enddo
5067 !grad          enddo
5068           do k=1,3
5069             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5070             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5071           enddo
5072         enddo
5073
5074         enddo ! iint
5075       enddo ! i
5076       do i=1,nct
5077         do j=1,3
5078           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5079           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5080           gradx_scp(j,i)=expon*gradx_scp(j,i)
5081         enddo
5082       enddo
5083 !******************************************************************************
5084 !
5085 !                              N O T E !!!
5086 !
5087 ! To save time the factor EXPON has been extracted from ALL components
5088 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5089 ! use!
5090 !
5091 !******************************************************************************
5092       return
5093       end subroutine escp
5094 !-----------------------------------------------------------------------------
5095       subroutine edis(ehpb)
5096 !
5097 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5098 !
5099 !      implicit real*8 (a-h,o-z)
5100 !      include 'DIMENSIONS'
5101 !      include 'COMMON.SBRIDGE'
5102 !      include 'COMMON.CHAIN'
5103 !      include 'COMMON.DERIV'
5104 !      include 'COMMON.VAR'
5105 !      include 'COMMON.INTERACT'
5106 !      include 'COMMON.IOUNITS'
5107       real(kind=8),dimension(3) :: ggg
5108 !el local variables
5109       integer :: i,j,ii,jj,iii,jjj,k
5110       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5111
5112       ehpb=0.0D0
5113 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5114 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5115       if (link_end.eq.0) return
5116       do i=link_start,link_end
5117 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5118 ! CA-CA distance used in regularization of structure.
5119         ii=ihpb(i)
5120         jj=jhpb(i)
5121 ! iii and jjj point to the residues for which the distance is assigned.
5122         if (ii.gt.nres) then
5123           iii=ii-nres
5124           jjj=jj-nres
5125         else
5126           iii=ii
5127           jjj=jj
5128         endif
5129 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5130 !     &    dhpb(i),dhpb1(i),forcon(i)
5131 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5132 !    distance and angle dependent SS bond potential.
5133 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5134 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5135         if (.not.dyn_ss .and. i.le.nss) then
5136 ! 15/02/13 CC dynamic SSbond - additional check
5137          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5138         iabs(itype(jjj,1)).eq.1) then
5139           call ssbond_ene(iii,jjj,eij)
5140           ehpb=ehpb+2*eij
5141 !d          write (iout,*) "eij",eij
5142          endif
5143         else if (ii.gt.nres .and. jj.gt.nres) then
5144 !c Restraints from contact prediction
5145           dd=dist(ii,jj)
5146           if (constr_dist.eq.11) then
5147             ehpb=ehpb+fordepth(i)**4.0d0 &
5148                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5149             fac=fordepth(i)**4.0d0 &
5150                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5151           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5152             ehpb,fordepth(i),dd
5153            else
5154           if (dhpb1(i).gt.0.0d0) then
5155             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5156             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5157 !c            write (iout,*) "beta nmr",
5158 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5159           else
5160             dd=dist(ii,jj)
5161             rdis=dd-dhpb(i)
5162 !C Get the force constant corresponding to this distance.
5163             waga=forcon(i)
5164 !C Calculate the contribution to energy.
5165             ehpb=ehpb+waga*rdis*rdis
5166 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5167 !C
5168 !C Evaluate gradient.
5169 !C
5170             fac=waga*rdis/dd
5171           endif
5172           endif
5173           do j=1,3
5174             ggg(j)=fac*(c(j,jj)-c(j,ii))
5175           enddo
5176           do j=1,3
5177             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5178             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5179           enddo
5180           do k=1,3
5181             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5182             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5183           enddo
5184         else
5185           dd=dist(ii,jj)
5186           if (constr_dist.eq.11) then
5187             ehpb=ehpb+fordepth(i)**4.0d0 &
5188                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5189             fac=fordepth(i)**4.0d0 &
5190                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5191           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5192          ehpb,fordepth(i),dd
5193            else
5194           if (dhpb1(i).gt.0.0d0) then
5195             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5196             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5197 !c            write (iout,*) "alph nmr",
5198 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5199           else
5200             rdis=dd-dhpb(i)
5201 !C Get the force constant corresponding to this distance.
5202             waga=forcon(i)
5203 !C Calculate the contribution to energy.
5204             ehpb=ehpb+waga*rdis*rdis
5205 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5206 !C
5207 !C Evaluate gradient.
5208 !C
5209             fac=waga*rdis/dd
5210           endif
5211           endif
5212
5213             do j=1,3
5214               ggg(j)=fac*(c(j,jj)-c(j,ii))
5215             enddo
5216 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5217 !C If this is a SC-SC distance, we need to calculate the contributions to the
5218 !C Cartesian gradient in the SC vectors (ghpbx).
5219           if (iii.lt.ii) then
5220           do j=1,3
5221             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5222             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5223           enddo
5224           endif
5225 !cgrad        do j=iii,jjj-1
5226 !cgrad          do k=1,3
5227 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5228 !cgrad          enddo
5229 !cgrad        enddo
5230           do k=1,3
5231             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5232             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5233           enddo
5234         endif
5235       enddo
5236       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5237
5238       return
5239       end subroutine edis
5240 !-----------------------------------------------------------------------------
5241       subroutine ssbond_ene(i,j,eij)
5242 !
5243 ! Calculate the distance and angle dependent SS-bond potential energy
5244 ! using a free-energy function derived based on RHF/6-31G** ab initio
5245 ! calculations of diethyl disulfide.
5246 !
5247 ! A. Liwo and U. Kozlowska, 11/24/03
5248 !
5249 !      implicit real*8 (a-h,o-z)
5250 !      include 'DIMENSIONS'
5251 !      include 'COMMON.SBRIDGE'
5252 !      include 'COMMON.CHAIN'
5253 !      include 'COMMON.DERIV'
5254 !      include 'COMMON.LOCAL'
5255 !      include 'COMMON.INTERACT'
5256 !      include 'COMMON.VAR'
5257 !      include 'COMMON.IOUNITS'
5258       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5259 !el local variables
5260       integer :: i,j,itypi,itypj,k
5261       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5262                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5263                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5264                    cosphi,ggk
5265
5266       itypi=iabs(itype(i,1))
5267       xi=c(1,nres+i)
5268       yi=c(2,nres+i)
5269       zi=c(3,nres+i)
5270       dxi=dc_norm(1,nres+i)
5271       dyi=dc_norm(2,nres+i)
5272       dzi=dc_norm(3,nres+i)
5273 !      dsci_inv=dsc_inv(itypi)
5274       dsci_inv=vbld_inv(nres+i)
5275       itypj=iabs(itype(j,1))
5276 !      dscj_inv=dsc_inv(itypj)
5277       dscj_inv=vbld_inv(nres+j)
5278       xj=c(1,nres+j)-xi
5279       yj=c(2,nres+j)-yi
5280       zj=c(3,nres+j)-zi
5281       dxj=dc_norm(1,nres+j)
5282       dyj=dc_norm(2,nres+j)
5283       dzj=dc_norm(3,nres+j)
5284       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5285       rij=dsqrt(rrij)
5286       erij(1)=xj*rij
5287       erij(2)=yj*rij
5288       erij(3)=zj*rij
5289       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5290       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5291       om12=dxi*dxj+dyi*dyj+dzi*dzj
5292       do k=1,3
5293         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5294         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5295       enddo
5296       rij=1.0d0/rij
5297       deltad=rij-d0cm
5298       deltat1=1.0d0-om1
5299       deltat2=1.0d0+om2
5300       deltat12=om2-om1+2.0d0
5301       cosphi=om12-om1*om2
5302       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5303         +akct*deltad*deltat12 &
5304         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5305 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5306 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5307 !     &  " deltat12",deltat12," eij",eij
5308       ed=2*akcm*deltad+akct*deltat12
5309       pom1=akct*deltad
5310       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5311       eom1=-2*akth*deltat1-pom1-om2*pom2
5312       eom2= 2*akth*deltat2+pom1-om1*pom2
5313       eom12=pom2
5314       do k=1,3
5315         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5316         ghpbx(k,i)=ghpbx(k,i)-ggk &
5317                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5318                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5319         ghpbx(k,j)=ghpbx(k,j)+ggk &
5320                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5321                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5322         ghpbc(k,i)=ghpbc(k,i)-ggk
5323         ghpbc(k,j)=ghpbc(k,j)+ggk
5324       enddo
5325 !
5326 ! Calculate the components of the gradient in DC and X
5327 !
5328 !grad      do k=i,j-1
5329 !grad        do l=1,3
5330 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5331 !grad        enddo
5332 !grad      enddo
5333       return
5334       end subroutine ssbond_ene
5335 !-----------------------------------------------------------------------------
5336       subroutine ebond(estr)
5337 !
5338 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5339 !
5340 !      implicit real*8 (a-h,o-z)
5341 !      include 'DIMENSIONS'
5342 !      include 'COMMON.LOCAL'
5343 !      include 'COMMON.GEO'
5344 !      include 'COMMON.INTERACT'
5345 !      include 'COMMON.DERIV'
5346 !      include 'COMMON.VAR'
5347 !      include 'COMMON.CHAIN'
5348 !      include 'COMMON.IOUNITS'
5349 !      include 'COMMON.NAMES'
5350 !      include 'COMMON.FFIELD'
5351 !      include 'COMMON.CONTROL'
5352 !      include 'COMMON.SETUP'
5353       real(kind=8),dimension(3) :: u,ud
5354 !el local variables
5355       integer :: i,j,iti,nbi,k
5356       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5357                    uprod1,uprod2
5358
5359       estr=0.0d0
5360       estr1=0.0d0
5361 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5362 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5363
5364       do i=ibondp_start,ibondp_end
5365         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5366         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5367 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5368 !C          do j=1,3
5369 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5370 !C            *dc(j,i-1)/vbld(i)
5371 !C          enddo
5372 !C          if (energy_dec) write(iout,*) &
5373 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5374         diff = vbld(i)-vbldpDUM
5375         else
5376         diff = vbld(i)-vbldp0
5377         endif
5378         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5379            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5380         estr=estr+diff*diff
5381         do j=1,3
5382           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5383         enddo
5384 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5385 !        endif
5386       enddo
5387       estr=0.5d0*AKP*estr+estr1
5388 !      print *,"estr_bb",estr,AKP
5389 !
5390 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5391 !
5392       do i=ibond_start,ibond_end
5393         iti=iabs(itype(i,1))
5394         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5395         if (iti.ne.10 .and. iti.ne.ntyp1) then
5396           nbi=nbondterm(iti)
5397           if (nbi.eq.1) then
5398             diff=vbld(i+nres)-vbldsc0(1,iti)
5399             if (energy_dec) write (iout,*) &
5400             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5401             AKSC(1,iti),AKSC(1,iti)*diff*diff
5402             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5403 !            print *,"estr_sc",estr
5404             do j=1,3
5405               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5406             enddo
5407           else
5408             do j=1,nbi
5409               diff=vbld(i+nres)-vbldsc0(j,iti)
5410               ud(j)=aksc(j,iti)*diff
5411               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5412             enddo
5413             uprod=u(1)
5414             do j=2,nbi
5415               uprod=uprod*u(j)
5416             enddo
5417             usum=0.0d0
5418             usumsqder=0.0d0
5419             do j=1,nbi
5420               uprod1=1.0d0
5421               uprod2=1.0d0
5422               do k=1,nbi
5423                 if (k.ne.j) then
5424                   uprod1=uprod1*u(k)
5425                   uprod2=uprod2*u(k)*u(k)
5426                 endif
5427               enddo
5428               usum=usum+uprod1
5429               usumsqder=usumsqder+ud(j)*uprod2
5430             enddo
5431             estr=estr+uprod/usum
5432 !            print *,"estr_sc",estr,i
5433
5434              if (energy_dec) write (iout,*) &
5435             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5436             AKSC(1,iti),uprod/usum
5437             do j=1,3
5438              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5439             enddo
5440           endif
5441         endif
5442       enddo
5443       return
5444       end subroutine ebond
5445 #ifdef CRYST_THETA
5446 !-----------------------------------------------------------------------------
5447       subroutine ebend(etheta)
5448 !
5449 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5450 ! angles gamma and its derivatives in consecutive thetas and gammas.
5451 !
5452       use comm_calcthet
5453 !      implicit real*8 (a-h,o-z)
5454 !      include 'DIMENSIONS'
5455 !      include 'COMMON.LOCAL'
5456 !      include 'COMMON.GEO'
5457 !      include 'COMMON.INTERACT'
5458 !      include 'COMMON.DERIV'
5459 !      include 'COMMON.VAR'
5460 !      include 'COMMON.CHAIN'
5461 !      include 'COMMON.IOUNITS'
5462 !      include 'COMMON.NAMES'
5463 !      include 'COMMON.FFIELD'
5464 !      include 'COMMON.CONTROL'
5465 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5466 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5467 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5468 !el      integer :: it
5469 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5470 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5471 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5472 !el local variables
5473       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5474        ichir21,ichir22
5475       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5476        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5477        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5478       real(kind=8),dimension(2) :: y,z
5479
5480       delta=0.02d0*pi
5481 !      time11=dexp(-2*time)
5482 !      time12=1.0d0
5483       etheta=0.0D0
5484 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5485       do i=ithet_start,ithet_end
5486         if (itype(i-1,1).eq.ntyp1) cycle
5487 ! Zero the energy function and its derivative at 0 or pi.
5488         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5489         it=itype(i-1,1)
5490         ichir1=isign(1,itype(i-2,1))
5491         ichir2=isign(1,itype(i,1))
5492          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5493          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5494          if (itype(i-1,1).eq.10) then
5495           itype1=isign(10,itype(i-2,1))
5496           ichir11=isign(1,itype(i-2,1))
5497           ichir12=isign(1,itype(i-2,1))
5498           itype2=isign(10,itype(i,1))
5499           ichir21=isign(1,itype(i,1))
5500           ichir22=isign(1,itype(i,1))
5501          endif
5502
5503         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5504 #ifdef OSF
5505           phii=phi(i)
5506           if (phii.ne.phii) phii=150.0
5507 #else
5508           phii=phi(i)
5509 #endif
5510           y(1)=dcos(phii)
5511           y(2)=dsin(phii)
5512         else
5513           y(1)=0.0D0
5514           y(2)=0.0D0
5515         endif
5516         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5517 #ifdef OSF
5518           phii1=phi(i+1)
5519           if (phii1.ne.phii1) phii1=150.0
5520           phii1=pinorm(phii1)
5521           z(1)=cos(phii1)
5522 #else
5523           phii1=phi(i+1)
5524           z(1)=dcos(phii1)
5525 #endif
5526           z(2)=dsin(phii1)
5527         else
5528           z(1)=0.0D0
5529           z(2)=0.0D0
5530         endif
5531 ! Calculate the "mean" value of theta from the part of the distribution
5532 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5533 ! In following comments this theta will be referred to as t_c.
5534         thet_pred_mean=0.0d0
5535         do k=1,2
5536             athetk=athet(k,it,ichir1,ichir2)
5537             bthetk=bthet(k,it,ichir1,ichir2)
5538           if (it.eq.10) then
5539              athetk=athet(k,itype1,ichir11,ichir12)
5540              bthetk=bthet(k,itype2,ichir21,ichir22)
5541           endif
5542          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5543         enddo
5544         dthett=thet_pred_mean*ssd
5545         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5546 ! Derivatives of the "mean" values in gamma1 and gamma2.
5547         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5548                +athet(2,it,ichir1,ichir2)*y(1))*ss
5549         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5550                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5551          if (it.eq.10) then
5552         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5553              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5554         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5555                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5556          endif
5557         if (theta(i).gt.pi-delta) then
5558           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5559                E_tc0)
5560           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5561           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5562           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5563               E_theta)
5564           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5565               E_tc)
5566         else if (theta(i).lt.delta) then
5567           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5568           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5569           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5570               E_theta)
5571           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5572           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5573               E_tc)
5574         else
5575           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5576               E_theta,E_tc)
5577         endif
5578         etheta=etheta+ethetai
5579         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5580             'ebend',i,ethetai
5581         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5582         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5583         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5584       enddo
5585 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5586
5587 ! Ufff.... We've done all this!!!
5588       return
5589       end subroutine ebend
5590 !-----------------------------------------------------------------------------
5591       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5592
5593       use comm_calcthet
5594 !      implicit real*8 (a-h,o-z)
5595 !      include 'DIMENSIONS'
5596 !      include 'COMMON.LOCAL'
5597 !      include 'COMMON.IOUNITS'
5598 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5599 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5600 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5601       integer :: i,j,k
5602       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5603 !el      integer :: it
5604 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5605 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5606 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5607 !el local variables
5608       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5609        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5610
5611 ! Calculate the contributions to both Gaussian lobes.
5612 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5613 ! The "polynomial part" of the "standard deviation" of this part of
5614 ! the distribution.
5615         sig=polthet(3,it)
5616         do j=2,0,-1
5617           sig=sig*thet_pred_mean+polthet(j,it)
5618         enddo
5619 ! Derivative of the "interior part" of the "standard deviation of the"
5620 ! gamma-dependent Gaussian lobe in t_c.
5621         sigtc=3*polthet(3,it)
5622         do j=2,1,-1
5623           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5624         enddo
5625         sigtc=sig*sigtc
5626 ! Set the parameters of both Gaussian lobes of the distribution.
5627 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5628         fac=sig*sig+sigc0(it)
5629         sigcsq=fac+fac
5630         sigc=1.0D0/sigcsq
5631 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5632         sigsqtc=-4.0D0*sigcsq*sigtc
5633 !       print *,i,sig,sigtc,sigsqtc
5634 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5635         sigtc=-sigtc/(fac*fac)
5636 ! Following variable is sigma(t_c)**(-2)
5637         sigcsq=sigcsq*sigcsq
5638         sig0i=sig0(it)
5639         sig0inv=1.0D0/sig0i**2
5640         delthec=thetai-thet_pred_mean
5641         delthe0=thetai-theta0i
5642         term1=-0.5D0*sigcsq*delthec*delthec
5643         term2=-0.5D0*sig0inv*delthe0*delthe0
5644 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5645 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5646 ! to the energy (this being the log of the distribution) at the end of energy
5647 ! term evaluation for this virtual-bond angle.
5648         if (term1.gt.term2) then
5649           termm=term1
5650           term2=dexp(term2-termm)
5651           term1=1.0d0
5652         else
5653           termm=term2
5654           term1=dexp(term1-termm)
5655           term2=1.0d0
5656         endif
5657 ! The ratio between the gamma-independent and gamma-dependent lobes of
5658 ! the distribution is a Gaussian function of thet_pred_mean too.
5659         diffak=gthet(2,it)-thet_pred_mean
5660         ratak=diffak/gthet(3,it)**2
5661         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5662 ! Let's differentiate it in thet_pred_mean NOW.
5663         aktc=ak*ratak
5664 ! Now put together the distribution terms to make complete distribution.
5665         termexp=term1+ak*term2
5666         termpre=sigc+ak*sig0i
5667 ! Contribution of the bending energy from this theta is just the -log of
5668 ! the sum of the contributions from the two lobes and the pre-exponential
5669 ! factor. Simple enough, isn't it?
5670         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5671 ! NOW the derivatives!!!
5672 ! 6/6/97 Take into account the deformation.
5673         E_theta=(delthec*sigcsq*term1 &
5674              +ak*delthe0*sig0inv*term2)/termexp
5675         E_tc=((sigtc+aktc*sig0i)/termpre &
5676             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5677              aktc*term2)/termexp)
5678       return
5679       end subroutine theteng
5680 #else
5681 !-----------------------------------------------------------------------------
5682       subroutine ebend(etheta,ethetacnstr)
5683 !
5684 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5685 ! angles gamma and its derivatives in consecutive thetas and gammas.
5686 ! ab initio-derived potentials from
5687 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5688 !
5689 !      implicit real*8 (a-h,o-z)
5690 !      include 'DIMENSIONS'
5691 !      include 'COMMON.LOCAL'
5692 !      include 'COMMON.GEO'
5693 !      include 'COMMON.INTERACT'
5694 !      include 'COMMON.DERIV'
5695 !      include 'COMMON.VAR'
5696 !      include 'COMMON.CHAIN'
5697 !      include 'COMMON.IOUNITS'
5698 !      include 'COMMON.NAMES'
5699 !      include 'COMMON.FFIELD'
5700 !      include 'COMMON.CONTROL'
5701       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5702       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5703       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5704       logical :: lprn=.false., lprn1=.false.
5705 !el local variables
5706       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5707       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5708       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5709 ! local variables for constrains
5710       real(kind=8) :: difi,thetiii
5711        integer itheta
5712
5713       etheta=0.0D0
5714       do i=ithet_start,ithet_end
5715         if (itype(i-1,1).eq.ntyp1) cycle
5716         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5717         if (iabs(itype(i+1,1)).eq.20) iblock=2
5718         if (iabs(itype(i+1,1)).ne.20) iblock=1
5719         dethetai=0.0d0
5720         dephii=0.0d0
5721         dephii1=0.0d0
5722         theti2=0.5d0*theta(i)
5723         ityp2=ithetyp((itype(i-1,1)))
5724         do k=1,nntheterm
5725           coskt(k)=dcos(k*theti2)
5726           sinkt(k)=dsin(k*theti2)
5727         enddo
5728         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5729 #ifdef OSF
5730           phii=phi(i)
5731           if (phii.ne.phii) phii=150.0
5732 #else
5733           phii=phi(i)
5734 #endif
5735           ityp1=ithetyp((itype(i-2,1)))
5736 ! propagation of chirality for glycine type
5737           do k=1,nsingle
5738             cosph1(k)=dcos(k*phii)
5739             sinph1(k)=dsin(k*phii)
5740           enddo
5741         else
5742           phii=0.0d0
5743           ityp1=ithetyp(itype(i-2,1))
5744           do k=1,nsingle
5745             cosph1(k)=0.0d0
5746             sinph1(k)=0.0d0
5747           enddo
5748         endif
5749         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5750 #ifdef OSF
5751           phii1=phi(i+1)
5752           if (phii1.ne.phii1) phii1=150.0
5753           phii1=pinorm(phii1)
5754 #else
5755           phii1=phi(i+1)
5756 #endif
5757           ityp3=ithetyp((itype(i,1)))
5758           do k=1,nsingle
5759             cosph2(k)=dcos(k*phii1)
5760             sinph2(k)=dsin(k*phii1)
5761           enddo
5762         else
5763           phii1=0.0d0
5764           ityp3=ithetyp(itype(i,1))
5765           do k=1,nsingle
5766             cosph2(k)=0.0d0
5767             sinph2(k)=0.0d0
5768           enddo
5769         endif
5770         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5771         do k=1,ndouble
5772           do l=1,k-1
5773             ccl=cosph1(l)*cosph2(k-l)
5774             ssl=sinph1(l)*sinph2(k-l)
5775             scl=sinph1(l)*cosph2(k-l)
5776             csl=cosph1(l)*sinph2(k-l)
5777             cosph1ph2(l,k)=ccl-ssl
5778             cosph1ph2(k,l)=ccl+ssl
5779             sinph1ph2(l,k)=scl+csl
5780             sinph1ph2(k,l)=scl-csl
5781           enddo
5782         enddo
5783         if (lprn) then
5784         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5785           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5786         write (iout,*) "coskt and sinkt"
5787         do k=1,nntheterm
5788           write (iout,*) k,coskt(k),sinkt(k)
5789         enddo
5790         endif
5791         do k=1,ntheterm
5792           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5793           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5794             *coskt(k)
5795           if (lprn) &
5796           write (iout,*) "k",k,&
5797            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5798            " ethetai",ethetai
5799         enddo
5800         if (lprn) then
5801         write (iout,*) "cosph and sinph"
5802         do k=1,nsingle
5803           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5804         enddo
5805         write (iout,*) "cosph1ph2 and sinph2ph2"
5806         do k=2,ndouble
5807           do l=1,k-1
5808             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5809                sinph1ph2(l,k),sinph1ph2(k,l)
5810           enddo
5811         enddo
5812         write(iout,*) "ethetai",ethetai
5813         endif
5814         do m=1,ntheterm2
5815           do k=1,nsingle
5816             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5817                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5818                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5819                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5820             ethetai=ethetai+sinkt(m)*aux
5821             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5822             dephii=dephii+k*sinkt(m)* &
5823                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5824                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5825             dephii1=dephii1+k*sinkt(m)* &
5826                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5827                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5828             if (lprn) &
5829             write (iout,*) "m",m," k",k," bbthet", &
5830                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5831                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5832                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5833                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5834           enddo
5835         enddo
5836         if (lprn) &
5837         write(iout,*) "ethetai",ethetai
5838         do m=1,ntheterm3
5839           do k=2,ndouble
5840             do l=1,k-1
5841               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5842                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5843                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5844                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5845               ethetai=ethetai+sinkt(m)*aux
5846               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5847               dephii=dephii+l*sinkt(m)* &
5848                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5849                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5850                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5851                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5852               dephii1=dephii1+(k-l)*sinkt(m)* &
5853                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5854                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5855                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5856                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5857               if (lprn) then
5858               write (iout,*) "m",m," k",k," l",l," ffthet",&
5859                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5860                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5861                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5862                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5863                   " ethetai",ethetai
5864               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5865                   cosph1ph2(k,l)*sinkt(m),&
5866                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5867               endif
5868             enddo
5869           enddo
5870         enddo
5871 10      continue
5872 !        lprn1=.true.
5873         if (lprn1) &
5874           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5875          i,theta(i)*rad2deg,phii*rad2deg,&
5876          phii1*rad2deg,ethetai
5877 !        lprn1=.false.
5878         etheta=etheta+ethetai
5879         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5880                                     'ebend',i,ethetai
5881         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5882         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5883         gloc(nphi+i-2,icg)=wang*dethetai
5884       enddo
5885 !-----------thete constrains
5886 !      if (tor_mode.ne.2) then
5887       ethetacnstr=0.0d0
5888 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5889       do i=ithetaconstr_start,ithetaconstr_end
5890         itheta=itheta_constr(i)
5891         thetiii=theta(itheta)
5892         difi=pinorm(thetiii-theta_constr0(i))
5893         if (difi.gt.theta_drange(i)) then
5894           difi=difi-theta_drange(i)
5895           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5896           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5897          +for_thet_constr(i)*difi**3
5898         else if (difi.lt.-drange(i)) then
5899           difi=difi+drange(i)
5900           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5901           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5902          +for_thet_constr(i)*difi**3
5903         else
5904           difi=0.0
5905         endif
5906        if (energy_dec) then
5907         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5908          i,itheta,rad2deg*thetiii, &
5909          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5910          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5911          gloc(itheta+nphi-2,icg)
5912         endif
5913       enddo
5914 !      endif
5915
5916       return
5917       end subroutine ebend
5918 #endif
5919 #ifdef CRYST_SC
5920 !-----------------------------------------------------------------------------
5921       subroutine esc(escloc)
5922 ! Calculate the local energy of a side chain and its derivatives in the
5923 ! corresponding virtual-bond valence angles THETA and the spherical angles
5924 ! ALPHA and OMEGA.
5925 !
5926       use comm_sccalc
5927 !      implicit real*8 (a-h,o-z)
5928 !      include 'DIMENSIONS'
5929 !      include 'COMMON.GEO'
5930 !      include 'COMMON.LOCAL'
5931 !      include 'COMMON.VAR'
5932 !      include 'COMMON.INTERACT'
5933 !      include 'COMMON.DERIV'
5934 !      include 'COMMON.CHAIN'
5935 !      include 'COMMON.IOUNITS'
5936 !      include 'COMMON.NAMES'
5937 !      include 'COMMON.FFIELD'
5938 !      include 'COMMON.CONTROL'
5939       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5940          ddersc0,ddummy,xtemp,temp
5941 !el      real(kind=8) :: time11,time12,time112,theti
5942       real(kind=8) :: escloc,delta
5943 !el      integer :: it,nlobit
5944 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5945 !el local variables
5946       integer :: i,k
5947       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5948        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5949       delta=0.02d0*pi
5950       escloc=0.0D0
5951 !     write (iout,'(a)') 'ESC'
5952       do i=loc_start,loc_end
5953         it=itype(i,1)
5954         if (it.eq.ntyp1) cycle
5955         if (it.eq.10) goto 1
5956         nlobit=nlob(iabs(it))
5957 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5958 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5959         theti=theta(i+1)-pipol
5960         x(1)=dtan(theti)
5961         x(2)=alph(i)
5962         x(3)=omeg(i)
5963
5964         if (x(2).gt.pi-delta) then
5965           xtemp(1)=x(1)
5966           xtemp(2)=pi-delta
5967           xtemp(3)=x(3)
5968           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5969           xtemp(2)=pi
5970           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5971           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5972               escloci,dersc(2))
5973           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5974               ddersc0(1),dersc(1))
5975           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5976               ddersc0(3),dersc(3))
5977           xtemp(2)=pi-delta
5978           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5979           xtemp(2)=pi
5980           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5981           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5982                   dersc0(2),esclocbi,dersc02)
5983           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5984                   dersc12,dersc01)
5985           call splinthet(x(2),0.5d0*delta,ss,ssd)
5986           dersc0(1)=dersc01
5987           dersc0(2)=dersc02
5988           dersc0(3)=0.0d0
5989           do k=1,3
5990             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5991           enddo
5992           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5993 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5994 !    &             esclocbi,ss,ssd
5995           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5996 !         escloci=esclocbi
5997 !         write (iout,*) escloci
5998         else if (x(2).lt.delta) then
5999           xtemp(1)=x(1)
6000           xtemp(2)=delta
6001           xtemp(3)=x(3)
6002           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6003           xtemp(2)=0.0d0
6004           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6005           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6006               escloci,dersc(2))
6007           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6008               ddersc0(1),dersc(1))
6009           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6010               ddersc0(3),dersc(3))
6011           xtemp(2)=delta
6012           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6013           xtemp(2)=0.0d0
6014           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6015           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6016                   dersc0(2),esclocbi,dersc02)
6017           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6018                   dersc12,dersc01)
6019           dersc0(1)=dersc01
6020           dersc0(2)=dersc02
6021           dersc0(3)=0.0d0
6022           call splinthet(x(2),0.5d0*delta,ss,ssd)
6023           do k=1,3
6024             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6025           enddo
6026           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6027 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6028 !    &             esclocbi,ss,ssd
6029           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6030 !         write (iout,*) escloci
6031         else
6032           call enesc(x,escloci,dersc,ddummy,.false.)
6033         endif
6034
6035         escloc=escloc+escloci
6036         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6037            'escloc',i,escloci
6038 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6039
6040         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6041          wscloc*dersc(1)
6042         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6043         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6044     1   continue
6045       enddo
6046       return
6047       end subroutine esc
6048 !-----------------------------------------------------------------------------
6049       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6050
6051       use comm_sccalc
6052 !      implicit real*8 (a-h,o-z)
6053 !      include 'DIMENSIONS'
6054 !      include 'COMMON.GEO'
6055 !      include 'COMMON.LOCAL'
6056 !      include 'COMMON.IOUNITS'
6057 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6058       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6059       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6060       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6061       real(kind=8) :: escloci
6062       logical :: mixed
6063 !el local variables
6064       integer :: j,iii,l,k !el,it,nlobit
6065       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6066 !el       time11,time12,time112
6067 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6068         escloc_i=0.0D0
6069         do j=1,3
6070           dersc(j)=0.0D0
6071           if (mixed) ddersc(j)=0.0d0
6072         enddo
6073         x3=x(3)
6074
6075 ! Because of periodicity of the dependence of the SC energy in omega we have
6076 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6077 ! To avoid underflows, first compute & store the exponents.
6078
6079         do iii=-1,1
6080
6081           x(3)=x3+iii*dwapi
6082
6083           do j=1,nlobit
6084             do k=1,3
6085               z(k)=x(k)-censc(k,j,it)
6086             enddo
6087             do k=1,3
6088               Axk=0.0D0
6089               do l=1,3
6090                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6091               enddo
6092               Ax(k,j,iii)=Axk
6093             enddo
6094             expfac=0.0D0
6095             do k=1,3
6096               expfac=expfac+Ax(k,j,iii)*z(k)
6097             enddo
6098             contr(j,iii)=expfac
6099           enddo ! j
6100
6101         enddo ! iii
6102
6103         x(3)=x3
6104 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6105 ! subsequent NaNs and INFs in energy calculation.
6106 ! Find the largest exponent
6107         emin=contr(1,-1)
6108         do iii=-1,1
6109           do j=1,nlobit
6110             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6111           enddo
6112         enddo
6113         emin=0.5D0*emin
6114 !d      print *,'it=',it,' emin=',emin
6115
6116 ! Compute the contribution to SC energy and derivatives
6117         do iii=-1,1
6118
6119           do j=1,nlobit
6120 #ifdef OSF
6121             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6122             if(adexp.ne.adexp) adexp=1.0
6123             expfac=dexp(adexp)
6124 #else
6125             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6126 #endif
6127 !d          print *,'j=',j,' expfac=',expfac
6128             escloc_i=escloc_i+expfac
6129             do k=1,3
6130               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6131             enddo
6132             if (mixed) then
6133               do k=1,3,2
6134                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6135                   +gaussc(k,2,j,it))*expfac
6136               enddo
6137             endif
6138           enddo
6139
6140         enddo ! iii
6141
6142         dersc(1)=dersc(1)/cos(theti)**2
6143         ddersc(1)=ddersc(1)/cos(theti)**2
6144         ddersc(3)=ddersc(3)
6145
6146         escloci=-(dlog(escloc_i)-emin)
6147         do j=1,3
6148           dersc(j)=dersc(j)/escloc_i
6149         enddo
6150         if (mixed) then
6151           do j=1,3,2
6152             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6153           enddo
6154         endif
6155       return
6156       end subroutine enesc
6157 !-----------------------------------------------------------------------------
6158       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6159
6160       use comm_sccalc
6161 !      implicit real*8 (a-h,o-z)
6162 !      include 'DIMENSIONS'
6163 !      include 'COMMON.GEO'
6164 !      include 'COMMON.LOCAL'
6165 !      include 'COMMON.IOUNITS'
6166 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6167       real(kind=8),dimension(3) :: x,z,dersc
6168       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6169       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6170       real(kind=8) :: escloci,dersc12,emin
6171       logical :: mixed
6172 !el local varables
6173       integer :: j,k,l !el,it,nlobit
6174       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6175
6176       escloc_i=0.0D0
6177
6178       do j=1,3
6179         dersc(j)=0.0D0
6180       enddo
6181
6182       do j=1,nlobit
6183         do k=1,2
6184           z(k)=x(k)-censc(k,j,it)
6185         enddo
6186         z(3)=dwapi
6187         do k=1,3
6188           Axk=0.0D0
6189           do l=1,3
6190             Axk=Axk+gaussc(l,k,j,it)*z(l)
6191           enddo
6192           Ax(k,j)=Axk
6193         enddo
6194         expfac=0.0D0
6195         do k=1,3
6196           expfac=expfac+Ax(k,j)*z(k)
6197         enddo
6198         contr(j)=expfac
6199       enddo ! j
6200
6201 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6202 ! subsequent NaNs and INFs in energy calculation.
6203 ! Find the largest exponent
6204       emin=contr(1)
6205       do j=1,nlobit
6206         if (emin.gt.contr(j)) emin=contr(j)
6207       enddo
6208       emin=0.5D0*emin
6209
6210 ! Compute the contribution to SC energy and derivatives
6211
6212       dersc12=0.0d0
6213       do j=1,nlobit
6214         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6215         escloc_i=escloc_i+expfac
6216         do k=1,2
6217           dersc(k)=dersc(k)+Ax(k,j)*expfac
6218         enddo
6219         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6220                   +gaussc(1,2,j,it))*expfac
6221         dersc(3)=0.0d0
6222       enddo
6223
6224       dersc(1)=dersc(1)/cos(theti)**2
6225       dersc12=dersc12/cos(theti)**2
6226       escloci=-(dlog(escloc_i)-emin)
6227       do j=1,2
6228         dersc(j)=dersc(j)/escloc_i
6229       enddo
6230       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6231       return
6232       end subroutine enesc_bound
6233 #else
6234 !-----------------------------------------------------------------------------
6235       subroutine esc(escloc)
6236 ! Calculate the local energy of a side chain and its derivatives in the
6237 ! corresponding virtual-bond valence angles THETA and the spherical angles
6238 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6239 ! added by Urszula Kozlowska. 07/11/2007
6240 !
6241       use comm_sccalc
6242 !      implicit real*8 (a-h,o-z)
6243 !      include 'DIMENSIONS'
6244 !      include 'COMMON.GEO'
6245 !      include 'COMMON.LOCAL'
6246 !      include 'COMMON.VAR'
6247 !      include 'COMMON.SCROT'
6248 !      include 'COMMON.INTERACT'
6249 !      include 'COMMON.DERIV'
6250 !      include 'COMMON.CHAIN'
6251 !      include 'COMMON.IOUNITS'
6252 !      include 'COMMON.NAMES'
6253 !      include 'COMMON.FFIELD'
6254 !      include 'COMMON.CONTROL'
6255 !      include 'COMMON.VECTORS'
6256       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6257       real(kind=8),dimension(65) :: x
6258       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6259          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6260       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6261       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6262          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6263 !el local variables
6264       integer :: i,j,k !el,it,nlobit
6265       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6266 !el      real(kind=8) :: time11,time12,time112,theti
6267 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6268       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6269                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6270                    sumene1x,sumene2x,sumene3x,sumene4x,&
6271                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6272                    cosfac2xx,sinfac2yy
6273 #ifdef DEBUG
6274       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6275                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6276                    de_dt_num
6277 #endif
6278 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6279
6280       delta=0.02d0*pi
6281       escloc=0.0D0
6282       do i=loc_start,loc_end
6283         if (itype(i,1).eq.ntyp1) cycle
6284         costtab(i+1) =dcos(theta(i+1))
6285         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6286         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6287         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6288         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6289         cosfac=dsqrt(cosfac2)
6290         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6291         sinfac=dsqrt(sinfac2)
6292         it=iabs(itype(i,1))
6293         if (it.eq.10) goto 1
6294 !
6295 !  Compute the axes of tghe local cartesian coordinates system; store in
6296 !   x_prime, y_prime and z_prime
6297 !
6298         do j=1,3
6299           x_prime(j) = 0.00
6300           y_prime(j) = 0.00
6301           z_prime(j) = 0.00
6302         enddo
6303 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6304 !     &   dc_norm(3,i+nres)
6305         do j = 1,3
6306           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6307           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6308         enddo
6309         do j = 1,3
6310           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6311         enddo
6312 !       write (2,*) "i",i
6313 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6314 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6315 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6316 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6317 !      & " xy",scalar(x_prime(1),y_prime(1)),
6318 !      & " xz",scalar(x_prime(1),z_prime(1)),
6319 !      & " yy",scalar(y_prime(1),y_prime(1)),
6320 !      & " yz",scalar(y_prime(1),z_prime(1)),
6321 !      & " zz",scalar(z_prime(1),z_prime(1))
6322 !
6323 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6324 ! to local coordinate system. Store in xx, yy, zz.
6325 !
6326         xx=0.0d0
6327         yy=0.0d0
6328         zz=0.0d0
6329         do j = 1,3
6330           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6331           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6332           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6333         enddo
6334
6335         xxtab(i)=xx
6336         yytab(i)=yy
6337         zztab(i)=zz
6338 !
6339 ! Compute the energy of the ith side cbain
6340 !
6341 !        write (2,*) "xx",xx," yy",yy," zz",zz
6342         it=iabs(itype(i,1))
6343         do j = 1,65
6344           x(j) = sc_parmin(j,it)
6345         enddo
6346 #ifdef CHECK_COORD
6347 !c diagnostics - remove later
6348         xx1 = dcos(alph(2))
6349         yy1 = dsin(alph(2))*dcos(omeg(2))
6350         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6351         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6352           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6353           xx1,yy1,zz1
6354 !,"  --- ", xx_w,yy_w,zz_w
6355 ! end diagnostics
6356 #endif
6357         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6358          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6359          + x(10)*yy*zz
6360         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6361          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6362          + x(20)*yy*zz
6363         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6364          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6365          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6366          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6367          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6368          +x(40)*xx*yy*zz
6369         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6370          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6371          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6372          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6373          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6374          +x(60)*xx*yy*zz
6375         dsc_i   = 0.743d0+x(61)
6376         dp2_i   = 1.9d0+x(62)
6377         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6378                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6379         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6380                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6381         s1=(1+x(63))/(0.1d0 + dscp1)
6382         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6383         s2=(1+x(65))/(0.1d0 + dscp2)
6384         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6385         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6386       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6387 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6388 !     &   sumene4,
6389 !     &   dscp1,dscp2,sumene
6390 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6391         escloc = escloc + sumene
6392 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6393 !     & ,zz,xx,yy
6394 !#define DEBUG
6395 #ifdef DEBUG
6396 !
6397 ! This section to check the numerical derivatives of the energy of ith side
6398 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6399 ! #define DEBUG in the code to turn it on.
6400 !
6401         write (2,*) "sumene               =",sumene
6402         aincr=1.0d-7
6403         xxsave=xx
6404         xx=xx+aincr
6405         write (2,*) xx,yy,zz
6406         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6407         de_dxx_num=(sumenep-sumene)/aincr
6408         xx=xxsave
6409         write (2,*) "xx+ sumene from enesc=",sumenep
6410         yysave=yy
6411         yy=yy+aincr
6412         write (2,*) xx,yy,zz
6413         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6414         de_dyy_num=(sumenep-sumene)/aincr
6415         yy=yysave
6416         write (2,*) "yy+ sumene from enesc=",sumenep
6417         zzsave=zz
6418         zz=zz+aincr
6419         write (2,*) xx,yy,zz
6420         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6421         de_dzz_num=(sumenep-sumene)/aincr
6422         zz=zzsave
6423         write (2,*) "zz+ sumene from enesc=",sumenep
6424         costsave=cost2tab(i+1)
6425         sintsave=sint2tab(i+1)
6426         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6427         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6428         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6429         de_dt_num=(sumenep-sumene)/aincr
6430         write (2,*) " t+ sumene from enesc=",sumenep
6431         cost2tab(i+1)=costsave
6432         sint2tab(i+1)=sintsave
6433 ! End of diagnostics section.
6434 #endif
6435 !
6436 ! Compute the gradient of esc
6437 !
6438 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6439         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6440         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6441         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6442         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6443         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6444         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6445         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6446         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6447         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6448            *(pom_s1/dscp1+pom_s16*dscp1**4)
6449         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6450            *(pom_s2/dscp2+pom_s26*dscp2**4)
6451         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6452         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6453         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6454         +x(40)*yy*zz
6455         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6456         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6457         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6458         +x(60)*yy*zz
6459         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6460               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6461               +(pom1+pom2)*pom_dx
6462 #ifdef DEBUG
6463         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6464 #endif
6465 !
6466         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6467         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6468         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6469         +x(40)*xx*zz
6470         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6471         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6472         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6473         +x(59)*zz**2 +x(60)*xx*zz
6474         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6475               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6476               +(pom1-pom2)*pom_dy
6477 #ifdef DEBUG
6478         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6479 #endif
6480 !
6481         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6482         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6483         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6484         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6485         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6486         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6487         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6488         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6489 #ifdef DEBUG
6490         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6491 #endif
6492 !
6493         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6494         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6495         +pom1*pom_dt1+pom2*pom_dt2
6496 #ifdef DEBUG
6497         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6498 #endif
6499 !
6500 !
6501        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6502        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6503        cosfac2xx=cosfac2*xx
6504        sinfac2yy=sinfac2*yy
6505        do k = 1,3
6506          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6507             vbld_inv(i+1)
6508          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6509             vbld_inv(i)
6510          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6511          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6512 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6513 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6514 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6515 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6516          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6517          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6518          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6519          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6520          dZZ_Ci1(k)=0.0d0
6521          dZZ_Ci(k)=0.0d0
6522          do j=1,3
6523            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6524            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6525            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6526            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6527          enddo
6528
6529          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6530          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6531          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6532          (z_prime(k)-zz*dC_norm(k,i+nres))
6533 !
6534          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6535          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6536        enddo
6537
6538        do k=1,3
6539          dXX_Ctab(k,i)=dXX_Ci(k)
6540          dXX_C1tab(k,i)=dXX_Ci1(k)
6541          dYY_Ctab(k,i)=dYY_Ci(k)
6542          dYY_C1tab(k,i)=dYY_Ci1(k)
6543          dZZ_Ctab(k,i)=dZZ_Ci(k)
6544          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6545          dXX_XYZtab(k,i)=dXX_XYZ(k)
6546          dYY_XYZtab(k,i)=dYY_XYZ(k)
6547          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6548        enddo
6549
6550        do k = 1,3
6551 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6552 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6553 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6554 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6555 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6556 !     &    dt_dci(k)
6557 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6558 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6559          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6560           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6561          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6562           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6563          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6564           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6565        enddo
6566 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6567 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6568
6569 ! to check gradient call subroutine check_grad
6570
6571     1 continue
6572       enddo
6573       return
6574       end subroutine esc
6575 !-----------------------------------------------------------------------------
6576       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6577 !      implicit none
6578       real(kind=8),dimension(65) :: x
6579       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6580         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6581
6582       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6583         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6584         + x(10)*yy*zz
6585       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6586         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6587         + x(20)*yy*zz
6588       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6589         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6590         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6591         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6592         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6593         +x(40)*xx*yy*zz
6594       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6595         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6596         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6597         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6598         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6599         +x(60)*xx*yy*zz
6600       dsc_i   = 0.743d0+x(61)
6601       dp2_i   = 1.9d0+x(62)
6602       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6603                 *(xx*cost2+yy*sint2))
6604       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6605                 *(xx*cost2-yy*sint2))
6606       s1=(1+x(63))/(0.1d0 + dscp1)
6607       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6608       s2=(1+x(65))/(0.1d0 + dscp2)
6609       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6610       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6611        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6612       enesc=sumene
6613       return
6614       end function enesc
6615 #endif
6616 !-----------------------------------------------------------------------------
6617       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6618 !
6619 ! This procedure calculates two-body contact function g(rij) and its derivative:
6620 !
6621 !           eps0ij                                     !       x < -1
6622 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6623 !            0                                         !       x > 1
6624 !
6625 ! where x=(rij-r0ij)/delta
6626 !
6627 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6628 !
6629 !      implicit none
6630       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6631       real(kind=8) :: x,x2,x4,delta
6632 !     delta=0.02D0*r0ij
6633 !      delta=0.2D0*r0ij
6634       x=(rij-r0ij)/delta
6635       if (x.lt.-1.0D0) then
6636         fcont=eps0ij
6637         fprimcont=0.0D0
6638       else if (x.le.1.0D0) then
6639         x2=x*x
6640         x4=x2*x2
6641         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6642         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6643       else
6644         fcont=0.0D0
6645         fprimcont=0.0D0
6646       endif
6647       return
6648       end subroutine gcont
6649 !-----------------------------------------------------------------------------
6650       subroutine splinthet(theti,delta,ss,ssder)
6651 !      implicit real*8 (a-h,o-z)
6652 !      include 'DIMENSIONS'
6653 !      include 'COMMON.VAR'
6654 !      include 'COMMON.GEO'
6655       real(kind=8) :: theti,delta,ss,ssder
6656       real(kind=8) :: thetup,thetlow
6657       thetup=pi-delta
6658       thetlow=delta
6659       if (theti.gt.pipol) then
6660         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6661       else
6662         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6663         ssder=-ssder
6664       endif
6665       return
6666       end subroutine splinthet
6667 !-----------------------------------------------------------------------------
6668       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6669 !      implicit none
6670       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6671       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6672       a1=fprim0*delta/(f1-f0)
6673       a2=3.0d0-2.0d0*a1
6674       a3=a1-2.0d0
6675       ksi=(x-x0)/delta
6676       ksi2=ksi*ksi
6677       ksi3=ksi2*ksi
6678       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6679       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6680       return
6681       end subroutine spline1
6682 !-----------------------------------------------------------------------------
6683       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6684 !      implicit none
6685       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6686       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6687       ksi=(x-x0)/delta
6688       ksi2=ksi*ksi
6689       ksi3=ksi2*ksi
6690       a1=fprim0x*delta
6691       a2=3*(f1x-f0x)-2*fprim0x*delta
6692       a3=fprim0x*delta-2*(f1x-f0x)
6693       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6694       return
6695       end subroutine spline2
6696 !-----------------------------------------------------------------------------
6697 #ifdef CRYST_TOR
6698 !-----------------------------------------------------------------------------
6699       subroutine etor(etors,edihcnstr)
6700 !      implicit real*8 (a-h,o-z)
6701 !      include 'DIMENSIONS'
6702 !      include 'COMMON.VAR'
6703 !      include 'COMMON.GEO'
6704 !      include 'COMMON.LOCAL'
6705 !      include 'COMMON.TORSION'
6706 !      include 'COMMON.INTERACT'
6707 !      include 'COMMON.DERIV'
6708 !      include 'COMMON.CHAIN'
6709 !      include 'COMMON.NAMES'
6710 !      include 'COMMON.IOUNITS'
6711 !      include 'COMMON.FFIELD'
6712 !      include 'COMMON.TORCNSTR'
6713 !      include 'COMMON.CONTROL'
6714       real(kind=8) :: etors,edihcnstr
6715       logical :: lprn
6716 !el local variables
6717       integer :: i,j,
6718       real(kind=8) :: phii,fac,etors_ii
6719
6720 ! Set lprn=.true. for debugging
6721       lprn=.false.
6722 !      lprn=.true.
6723       etors=0.0D0
6724       do i=iphi_start,iphi_end
6725       etors_ii=0.0D0
6726         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6727             .or. itype(i,1).eq.ntyp1) cycle
6728         itori=itortyp(itype(i-2,1))
6729         itori1=itortyp(itype(i-1,1))
6730         phii=phi(i)
6731         gloci=0.0D0
6732 ! Proline-Proline pair is a special case...
6733         if (itori.eq.3 .and. itori1.eq.3) then
6734           if (phii.gt.-dwapi3) then
6735             cosphi=dcos(3*phii)
6736             fac=1.0D0/(1.0D0-cosphi)
6737             etorsi=v1(1,3,3)*fac
6738             etorsi=etorsi+etorsi
6739             etors=etors+etorsi-v1(1,3,3)
6740             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6741             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6742           endif
6743           do j=1,3
6744             v1ij=v1(j+1,itori,itori1)
6745             v2ij=v2(j+1,itori,itori1)
6746             cosphi=dcos(j*phii)
6747             sinphi=dsin(j*phii)
6748             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6749             if (energy_dec) etors_ii=etors_ii+ &
6750                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6751             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6752           enddo
6753         else
6754           do j=1,nterm_old
6755             v1ij=v1(j,itori,itori1)
6756             v2ij=v2(j,itori,itori1)
6757             cosphi=dcos(j*phii)
6758             sinphi=dsin(j*phii)
6759             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6760             if (energy_dec) etors_ii=etors_ii+ &
6761                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6762             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6763           enddo
6764         endif
6765         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6766              'etor',i,etors_ii
6767         if (lprn) &
6768         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6769         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6770         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6771         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6772 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6773       enddo
6774 ! 6/20/98 - dihedral angle constraints
6775       edihcnstr=0.0d0
6776       do i=1,ndih_constr
6777         itori=idih_constr(i)
6778         phii=phi(itori)
6779         difi=phii-phi0(i)
6780         if (difi.gt.drange(i)) then
6781           difi=difi-drange(i)
6782           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6783           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6784         else if (difi.lt.-drange(i)) then
6785           difi=difi+drange(i)
6786           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6787           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6788         endif
6789 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6790 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6791       enddo
6792 !      write (iout,*) 'edihcnstr',edihcnstr
6793       return
6794       end subroutine etor
6795 !-----------------------------------------------------------------------------
6796       subroutine etor_d(etors_d)
6797       real(kind=8) :: etors_d
6798       etors_d=0.0d0
6799       return
6800       end subroutine etor_d
6801 #else
6802 !-----------------------------------------------------------------------------
6803       subroutine etor(etors,edihcnstr)
6804 !      implicit real*8 (a-h,o-z)
6805 !      include 'DIMENSIONS'
6806 !      include 'COMMON.VAR'
6807 !      include 'COMMON.GEO'
6808 !      include 'COMMON.LOCAL'
6809 !      include 'COMMON.TORSION'
6810 !      include 'COMMON.INTERACT'
6811 !      include 'COMMON.DERIV'
6812 !      include 'COMMON.CHAIN'
6813 !      include 'COMMON.NAMES'
6814 !      include 'COMMON.IOUNITS'
6815 !      include 'COMMON.FFIELD'
6816 !      include 'COMMON.TORCNSTR'
6817 !      include 'COMMON.CONTROL'
6818       real(kind=8) :: etors,edihcnstr
6819       logical :: lprn
6820 !el local variables
6821       integer :: i,j,iblock,itori,itori1
6822       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6823                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6824 ! Set lprn=.true. for debugging
6825       lprn=.false.
6826 !     lprn=.true.
6827       etors=0.0D0
6828       do i=iphi_start,iphi_end
6829         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6830              .or. itype(i-3,1).eq.ntyp1 &
6831              .or. itype(i,1).eq.ntyp1) cycle
6832         etors_ii=0.0D0
6833          if (iabs(itype(i,1)).eq.20) then
6834          iblock=2
6835          else
6836          iblock=1
6837          endif
6838         itori=itortyp(itype(i-2,1))
6839         itori1=itortyp(itype(i-1,1))
6840         phii=phi(i)
6841         gloci=0.0D0
6842 ! Regular cosine and sine terms
6843         do j=1,nterm(itori,itori1,iblock)
6844           v1ij=v1(j,itori,itori1,iblock)
6845           v2ij=v2(j,itori,itori1,iblock)
6846           cosphi=dcos(j*phii)
6847           sinphi=dsin(j*phii)
6848           etors=etors+v1ij*cosphi+v2ij*sinphi
6849           if (energy_dec) etors_ii=etors_ii+ &
6850                      v1ij*cosphi+v2ij*sinphi
6851           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6852         enddo
6853 ! Lorentz terms
6854 !                         v1
6855 !  E = SUM ----------------------------------- - v1
6856 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6857 !
6858         cosphi=dcos(0.5d0*phii)
6859         sinphi=dsin(0.5d0*phii)
6860         do j=1,nlor(itori,itori1,iblock)
6861           vl1ij=vlor1(j,itori,itori1)
6862           vl2ij=vlor2(j,itori,itori1)
6863           vl3ij=vlor3(j,itori,itori1)
6864           pom=vl2ij*cosphi+vl3ij*sinphi
6865           pom1=1.0d0/(pom*pom+1.0d0)
6866           etors=etors+vl1ij*pom1
6867           if (energy_dec) etors_ii=etors_ii+ &
6868                      vl1ij*pom1
6869           pom=-pom*pom1*pom1
6870           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6871         enddo
6872 ! Subtract the constant term
6873         etors=etors-v0(itori,itori1,iblock)
6874           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6875                'etor',i,etors_ii-v0(itori,itori1,iblock)
6876         if (lprn) &
6877         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6878         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6879         (v1(j,itori,itori1,iblock),j=1,6),&
6880         (v2(j,itori,itori1,iblock),j=1,6)
6881         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6882 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6883       enddo
6884 ! 6/20/98 - dihedral angle constraints
6885       edihcnstr=0.0d0
6886 !      do i=1,ndih_constr
6887       do i=idihconstr_start,idihconstr_end
6888         itori=idih_constr(i)
6889         phii=phi(itori)
6890         difi=pinorm(phii-phi0(i))
6891         if (difi.gt.drange(i)) then
6892           difi=difi-drange(i)
6893           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6894           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6895         else if (difi.lt.-drange(i)) then
6896           difi=difi+drange(i)
6897           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6898           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6899         else
6900           difi=0.0
6901         endif
6902 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6903 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6904 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6905       enddo
6906 !d       write (iout,*) 'edihcnstr',edihcnstr
6907       return
6908       end subroutine etor
6909 !-----------------------------------------------------------------------------
6910       subroutine etor_d(etors_d)
6911 ! 6/23/01 Compute double torsional energy
6912 !      implicit real*8 (a-h,o-z)
6913 !      include 'DIMENSIONS'
6914 !      include 'COMMON.VAR'
6915 !      include 'COMMON.GEO'
6916 !      include 'COMMON.LOCAL'
6917 !      include 'COMMON.TORSION'
6918 !      include 'COMMON.INTERACT'
6919 !      include 'COMMON.DERIV'
6920 !      include 'COMMON.CHAIN'
6921 !      include 'COMMON.NAMES'
6922 !      include 'COMMON.IOUNITS'
6923 !      include 'COMMON.FFIELD'
6924 !      include 'COMMON.TORCNSTR'
6925       real(kind=8) :: etors_d,etors_d_ii
6926       logical :: lprn
6927 !el local variables
6928       integer :: i,j,k,l,itori,itori1,itori2,iblock
6929       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6930                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6931                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6932                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6933 ! Set lprn=.true. for debugging
6934       lprn=.false.
6935 !     lprn=.true.
6936       etors_d=0.0D0
6937 !      write(iout,*) "a tu??"
6938       do i=iphid_start,iphid_end
6939         etors_d_ii=0.0D0
6940         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6941             .or. itype(i-3,1).eq.ntyp1 &
6942             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6943         itori=itortyp(itype(i-2,1))
6944         itori1=itortyp(itype(i-1,1))
6945         itori2=itortyp(itype(i,1))
6946         phii=phi(i)
6947         phii1=phi(i+1)
6948         gloci1=0.0D0
6949         gloci2=0.0D0
6950         iblock=1
6951         if (iabs(itype(i+1,1)).eq.20) iblock=2
6952
6953 ! Regular cosine and sine terms
6954         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6955           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6956           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6957           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6958           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6959           cosphi1=dcos(j*phii)
6960           sinphi1=dsin(j*phii)
6961           cosphi2=dcos(j*phii1)
6962           sinphi2=dsin(j*phii1)
6963           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6964            v2cij*cosphi2+v2sij*sinphi2
6965           if (energy_dec) etors_d_ii=etors_d_ii+ &
6966            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6967           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6968           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6969         enddo
6970         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6971           do l=1,k-1
6972             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6973             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6974             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6975             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6976             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6977             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6978             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6979             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6980             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6981               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6982             if (energy_dec) etors_d_ii=etors_d_ii+ &
6983               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6984               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6985             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6986               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6987             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6988               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6989           enddo
6990         enddo
6991         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6992                             'etor_d',i,etors_d_ii
6993         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6994         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6995       enddo
6996       return
6997       end subroutine etor_d
6998 #endif
6999 !-----------------------------------------------------------------------------
7000       subroutine eback_sc_corr(esccor)
7001 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7002 !        conformational states; temporarily implemented as differences
7003 !        between UNRES torsional potentials (dependent on three types of
7004 !        residues) and the torsional potentials dependent on all 20 types
7005 !        of residues computed from AM1  energy surfaces of terminally-blocked
7006 !        amino-acid residues.
7007 !      implicit real*8 (a-h,o-z)
7008 !      include 'DIMENSIONS'
7009 !      include 'COMMON.VAR'
7010 !      include 'COMMON.GEO'
7011 !      include 'COMMON.LOCAL'
7012 !      include 'COMMON.TORSION'
7013 !      include 'COMMON.SCCOR'
7014 !      include 'COMMON.INTERACT'
7015 !      include 'COMMON.DERIV'
7016 !      include 'COMMON.CHAIN'
7017 !      include 'COMMON.NAMES'
7018 !      include 'COMMON.IOUNITS'
7019 !      include 'COMMON.FFIELD'
7020 !      include 'COMMON.CONTROL'
7021       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7022                    cosphi,sinphi
7023       logical :: lprn
7024       integer :: i,interty,j,isccori,isccori1,intertyp
7025 ! Set lprn=.true. for debugging
7026       lprn=.false.
7027 !      lprn=.true.
7028 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7029       esccor=0.0D0
7030       do i=itau_start,itau_end
7031         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7032         esccor_ii=0.0D0
7033         isccori=isccortyp(itype(i-2,1))
7034         isccori1=isccortyp(itype(i-1,1))
7035
7036 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7037         phii=phi(i)
7038         do intertyp=1,3 !intertyp
7039          esccor_ii=0.0D0
7040 !c Added 09 May 2012 (Adasko)
7041 !c  Intertyp means interaction type of backbone mainchain correlation:
7042 !   1 = SC...Ca...Ca...Ca
7043 !   2 = Ca...Ca...Ca...SC
7044 !   3 = SC...Ca...Ca...SCi
7045         gloci=0.0D0
7046         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7047             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7048             (itype(i-1,1).eq.ntyp1))) &
7049           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7050            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7051            .or.(itype(i,1).eq.ntyp1))) &
7052           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7053             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7054             (itype(i-3,1).eq.ntyp1)))) cycle
7055         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7056         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7057        cycle
7058        do j=1,nterm_sccor(isccori,isccori1)
7059           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7060           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7061           cosphi=dcos(j*tauangle(intertyp,i))
7062           sinphi=dsin(j*tauangle(intertyp,i))
7063           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7064           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7065           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7066         enddo
7067         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7068                                 'esccor',i,intertyp,esccor_ii
7069 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7070         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7071         if (lprn) &
7072         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7073         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7074         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7075         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7076         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7077        enddo !intertyp
7078       enddo
7079
7080       return
7081       end subroutine eback_sc_corr
7082 !-----------------------------------------------------------------------------
7083       subroutine multibody(ecorr)
7084 ! This subroutine calculates multi-body contributions to energy following
7085 ! the idea of Skolnick et al. If side chains I and J make a contact and
7086 ! at the same time side chains I+1 and J+1 make a contact, an extra
7087 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7088 !      implicit real*8 (a-h,o-z)
7089 !      include 'DIMENSIONS'
7090 !      include 'COMMON.IOUNITS'
7091 !      include 'COMMON.DERIV'
7092 !      include 'COMMON.INTERACT'
7093 !      include 'COMMON.CONTACTS'
7094       real(kind=8),dimension(3) :: gx,gx1
7095       logical :: lprn
7096       real(kind=8) :: ecorr
7097       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7098 ! Set lprn=.true. for debugging
7099       lprn=.false.
7100
7101       if (lprn) then
7102         write (iout,'(a)') 'Contact function values:'
7103         do i=nnt,nct-2
7104           write (iout,'(i2,20(1x,i2,f10.5))') &
7105               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7106         enddo
7107       endif
7108       ecorr=0.0D0
7109
7110 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7111 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7112       do i=nnt,nct
7113         do j=1,3
7114           gradcorr(j,i)=0.0D0
7115           gradxorr(j,i)=0.0D0
7116         enddo
7117       enddo
7118       do i=nnt,nct-2
7119
7120         DO ISHIFT = 3,4
7121
7122         i1=i+ishift
7123         num_conti=num_cont(i)
7124         num_conti1=num_cont(i1)
7125         do jj=1,num_conti
7126           j=jcont(jj,i)
7127           do kk=1,num_conti1
7128             j1=jcont(kk,i1)
7129             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7130 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7131 !d   &                   ' ishift=',ishift
7132 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7133 ! The system gains extra energy.
7134               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7135             endif   ! j1==j+-ishift
7136           enddo     ! kk
7137         enddo       ! jj
7138
7139         ENDDO ! ISHIFT
7140
7141       enddo         ! i
7142       return
7143       end subroutine multibody
7144 !-----------------------------------------------------------------------------
7145       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7146 !      implicit real*8 (a-h,o-z)
7147 !      include 'DIMENSIONS'
7148 !      include 'COMMON.IOUNITS'
7149 !      include 'COMMON.DERIV'
7150 !      include 'COMMON.INTERACT'
7151 !      include 'COMMON.CONTACTS'
7152       real(kind=8),dimension(3) :: gx,gx1
7153       logical :: lprn
7154       integer :: i,j,k,l,jj,kk,m,ll
7155       real(kind=8) :: eij,ekl
7156       lprn=.false.
7157       eij=facont(jj,i)
7158       ekl=facont(kk,k)
7159 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7160 ! Calculate the multi-body contribution to energy.
7161 ! Calculate multi-body contributions to the gradient.
7162 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7163 !d   & k,l,(gacont(m,kk,k),m=1,3)
7164       do m=1,3
7165         gx(m) =ekl*gacont(m,jj,i)
7166         gx1(m)=eij*gacont(m,kk,k)
7167         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7168         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7169         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7170         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7171       enddo
7172       do m=i,j-1
7173         do ll=1,3
7174           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7175         enddo
7176       enddo
7177       do m=k,l-1
7178         do ll=1,3
7179           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7180         enddo
7181       enddo
7182       esccorr=-eij*ekl
7183       return
7184       end function esccorr
7185 !-----------------------------------------------------------------------------
7186       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7187 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7188 !      implicit real*8 (a-h,o-z)
7189 !      include 'DIMENSIONS'
7190 !      include 'COMMON.IOUNITS'
7191 #ifdef MPI
7192       include "mpif.h"
7193 !      integer :: maxconts !max_cont=maxconts  =nres/4
7194       integer,parameter :: max_dim=26
7195       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7196       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7197 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7198 !el      common /przechowalnia/ zapas
7199       integer :: status(MPI_STATUS_SIZE)
7200       integer,dimension((nres/4)*2) :: req !maxconts*2
7201       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7202 #endif
7203 !      include 'COMMON.SETUP'
7204 !      include 'COMMON.FFIELD'
7205 !      include 'COMMON.DERIV'
7206 !      include 'COMMON.INTERACT'
7207 !      include 'COMMON.CONTACTS'
7208 !      include 'COMMON.CONTROL'
7209 !      include 'COMMON.LOCAL'
7210       real(kind=8),dimension(3) :: gx,gx1
7211       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7212       logical :: lprn,ldone
7213 !el local variables
7214       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7215               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7216
7217 ! Set lprn=.true. for debugging
7218       lprn=.false.
7219 #ifdef MPI
7220 !      maxconts=nres/4
7221       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7222       n_corr=0
7223       n_corr1=0
7224       if (nfgtasks.le.1) goto 30
7225       if (lprn) then
7226         write (iout,'(a)') 'Contact function values before RECEIVE:'
7227         do i=nnt,nct-2
7228           write (iout,'(2i3,50(1x,i2,f5.2))') &
7229           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7230           j=1,num_cont_hb(i))
7231         enddo
7232       endif
7233       call flush(iout)
7234       do i=1,ntask_cont_from
7235         ncont_recv(i)=0
7236       enddo
7237       do i=1,ntask_cont_to
7238         ncont_sent(i)=0
7239       enddo
7240 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7241 !     & ntask_cont_to
7242 ! Make the list of contacts to send to send to other procesors
7243 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7244 !      call flush(iout)
7245       do i=iturn3_start,iturn3_end
7246 !        write (iout,*) "make contact list turn3",i," num_cont",
7247 !     &    num_cont_hb(i)
7248         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7249       enddo
7250       do i=iturn4_start,iturn4_end
7251 !        write (iout,*) "make contact list turn4",i," num_cont",
7252 !     &   num_cont_hb(i)
7253         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7254       enddo
7255       do ii=1,nat_sent
7256         i=iat_sent(ii)
7257 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7258 !     &    num_cont_hb(i)
7259         do j=1,num_cont_hb(i)
7260         do k=1,4
7261           jjc=jcont_hb(j,i)
7262           iproc=iint_sent_local(k,jjc,ii)
7263 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7264           if (iproc.gt.0) then
7265             ncont_sent(iproc)=ncont_sent(iproc)+1
7266             nn=ncont_sent(iproc)
7267             zapas(1,nn,iproc)=i
7268             zapas(2,nn,iproc)=jjc
7269             zapas(3,nn,iproc)=facont_hb(j,i)
7270             zapas(4,nn,iproc)=ees0p(j,i)
7271             zapas(5,nn,iproc)=ees0m(j,i)
7272             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7273             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7274             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7275             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7276             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7277             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7278             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7279             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7280             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7281             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7282             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7283             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7284             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7285             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7286             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7287             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7288             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7289             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7290             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7291             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7292             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7293           endif
7294         enddo
7295         enddo
7296       enddo
7297       if (lprn) then
7298       write (iout,*) &
7299         "Numbers of contacts to be sent to other processors",&
7300         (ncont_sent(i),i=1,ntask_cont_to)
7301       write (iout,*) "Contacts sent"
7302       do ii=1,ntask_cont_to
7303         nn=ncont_sent(ii)
7304         iproc=itask_cont_to(ii)
7305         write (iout,*) nn," contacts to processor",iproc,&
7306          " of CONT_TO_COMM group"
7307         do i=1,nn
7308           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7309         enddo
7310       enddo
7311       call flush(iout)
7312       endif
7313       CorrelType=477
7314       CorrelID=fg_rank+1
7315       CorrelType1=478
7316       CorrelID1=nfgtasks+fg_rank+1
7317       ireq=0
7318 ! Receive the numbers of needed contacts from other processors
7319       do ii=1,ntask_cont_from
7320         iproc=itask_cont_from(ii)
7321         ireq=ireq+1
7322         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7323           FG_COMM,req(ireq),IERR)
7324       enddo
7325 !      write (iout,*) "IRECV ended"
7326 !      call flush(iout)
7327 ! Send the number of contacts needed by other processors
7328       do ii=1,ntask_cont_to
7329         iproc=itask_cont_to(ii)
7330         ireq=ireq+1
7331         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7332           FG_COMM,req(ireq),IERR)
7333       enddo
7334 !      write (iout,*) "ISEND ended"
7335 !      write (iout,*) "number of requests (nn)",ireq
7336       call flush(iout)
7337       if (ireq.gt.0) &
7338         call MPI_Waitall(ireq,req,status_array,ierr)
7339 !      write (iout,*)
7340 !     &  "Numbers of contacts to be received from other processors",
7341 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7342 !      call flush(iout)
7343 ! Receive contacts
7344       ireq=0
7345       do ii=1,ntask_cont_from
7346         iproc=itask_cont_from(ii)
7347         nn=ncont_recv(ii)
7348 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7349 !     &   " of CONT_TO_COMM group"
7350         call flush(iout)
7351         if (nn.gt.0) then
7352           ireq=ireq+1
7353           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7354           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7355 !          write (iout,*) "ireq,req",ireq,req(ireq)
7356         endif
7357       enddo
7358 ! Send the contacts to processors that need them
7359       do ii=1,ntask_cont_to
7360         iproc=itask_cont_to(ii)
7361         nn=ncont_sent(ii)
7362 !        write (iout,*) nn," contacts to processor",iproc,
7363 !     &   " of CONT_TO_COMM group"
7364         if (nn.gt.0) then
7365           ireq=ireq+1
7366           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7367             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7368 !          write (iout,*) "ireq,req",ireq,req(ireq)
7369 !          do i=1,nn
7370 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7371 !          enddo
7372         endif
7373       enddo
7374 !      write (iout,*) "number of requests (contacts)",ireq
7375 !      write (iout,*) "req",(req(i),i=1,4)
7376 !      call flush(iout)
7377       if (ireq.gt.0) &
7378        call MPI_Waitall(ireq,req,status_array,ierr)
7379       do iii=1,ntask_cont_from
7380         iproc=itask_cont_from(iii)
7381         nn=ncont_recv(iii)
7382         if (lprn) then
7383         write (iout,*) "Received",nn," contacts from processor",iproc,&
7384          " of CONT_FROM_COMM group"
7385         call flush(iout)
7386         do i=1,nn
7387           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7388         enddo
7389         call flush(iout)
7390         endif
7391         do i=1,nn
7392           ii=zapas_recv(1,i,iii)
7393 ! Flag the received contacts to prevent double-counting
7394           jj=-zapas_recv(2,i,iii)
7395 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7396 !          call flush(iout)
7397           nnn=num_cont_hb(ii)+1
7398           num_cont_hb(ii)=nnn
7399           jcont_hb(nnn,ii)=jj
7400           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7401           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7402           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7403           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7404           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7405           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7406           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7407           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7408           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7409           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7410           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7411           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7412           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7413           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7414           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7415           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7416           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7417           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7418           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7419           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7420           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7421           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7422           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7423           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7424         enddo
7425       enddo
7426       call flush(iout)
7427       if (lprn) then
7428         write (iout,'(a)') 'Contact function values after receive:'
7429         do i=nnt,nct-2
7430           write (iout,'(2i3,50(1x,i3,f5.2))') &
7431           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7432           j=1,num_cont_hb(i))
7433         enddo
7434         call flush(iout)
7435       endif
7436    30 continue
7437 #endif
7438       if (lprn) then
7439         write (iout,'(a)') 'Contact function values:'
7440         do i=nnt,nct-2
7441           write (iout,'(2i3,50(1x,i3,f5.2))') &
7442           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7443           j=1,num_cont_hb(i))
7444         enddo
7445       endif
7446       ecorr=0.0D0
7447
7448 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7449 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7450 ! Remove the loop below after debugging !!!
7451       do i=nnt,nct
7452         do j=1,3
7453           gradcorr(j,i)=0.0D0
7454           gradxorr(j,i)=0.0D0
7455         enddo
7456       enddo
7457 ! Calculate the local-electrostatic correlation terms
7458       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7459         i1=i+1
7460         num_conti=num_cont_hb(i)
7461         num_conti1=num_cont_hb(i+1)
7462         do jj=1,num_conti
7463           j=jcont_hb(jj,i)
7464           jp=iabs(j)
7465           do kk=1,num_conti1
7466             j1=jcont_hb(kk,i1)
7467             jp1=iabs(j1)
7468 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7469 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7470             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7471                 .or. j.lt.0 .and. j1.gt.0) .and. &
7472                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7473 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7474 ! The system gains extra energy.
7475               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7476               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7477                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7478               n_corr=n_corr+1
7479             else if (j1.eq.j) then
7480 ! Contacts I-J and I-(J+1) occur simultaneously.
7481 ! The system loses extra energy.
7482 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7483             endif
7484           enddo ! kk
7485           do kk=1,num_conti
7486             j1=jcont_hb(kk,i)
7487 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7488 !    &         ' jj=',jj,' kk=',kk
7489             if (j1.eq.j+1) then
7490 ! Contacts I-J and (I+1)-J occur simultaneously.
7491 ! The system loses extra energy.
7492 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7493             endif ! j1==j+1
7494           enddo ! kk
7495         enddo ! jj
7496       enddo ! i
7497       return
7498       end subroutine multibody_hb
7499 !-----------------------------------------------------------------------------
7500       subroutine add_hb_contact(ii,jj,itask)
7501 !      implicit real*8 (a-h,o-z)
7502 !      include "DIMENSIONS"
7503 !      include "COMMON.IOUNITS"
7504 !      include "COMMON.CONTACTS"
7505 !      integer,parameter :: maxconts=nres/4
7506       integer,parameter :: max_dim=26
7507       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7508 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7509 !      common /przechowalnia/ zapas
7510       integer :: i,j,ii,jj,iproc,nn,jjc
7511       integer,dimension(4) :: itask
7512 !      write (iout,*) "itask",itask
7513       do i=1,2
7514         iproc=itask(i)
7515         if (iproc.gt.0) then
7516           do j=1,num_cont_hb(ii)
7517             jjc=jcont_hb(j,ii)
7518 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7519             if (jjc.eq.jj) then
7520               ncont_sent(iproc)=ncont_sent(iproc)+1
7521               nn=ncont_sent(iproc)
7522               zapas(1,nn,iproc)=ii
7523               zapas(2,nn,iproc)=jjc
7524               zapas(3,nn,iproc)=facont_hb(j,ii)
7525               zapas(4,nn,iproc)=ees0p(j,ii)
7526               zapas(5,nn,iproc)=ees0m(j,ii)
7527               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7528               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7529               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7530               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7531               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7532               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7533               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7534               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7535               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7536               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7537               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7538               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7539               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7540               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7541               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7542               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7543               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7544               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7545               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7546               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7547               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7548               exit
7549             endif
7550           enddo
7551         endif
7552       enddo
7553       return
7554       end subroutine add_hb_contact
7555 !-----------------------------------------------------------------------------
7556       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7557 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7558 !      implicit real*8 (a-h,o-z)
7559 !      include 'DIMENSIONS'
7560 !      include 'COMMON.IOUNITS'
7561       integer,parameter :: max_dim=70
7562 #ifdef MPI
7563       include "mpif.h"
7564 !      integer :: maxconts !max_cont=maxconts=nres/4
7565       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7566       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7567 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7568 !      common /przechowalnia/ zapas
7569       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7570         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7571         ierr,iii,nnn
7572 #endif
7573 !      include 'COMMON.SETUP'
7574 !      include 'COMMON.FFIELD'
7575 !      include 'COMMON.DERIV'
7576 !      include 'COMMON.LOCAL'
7577 !      include 'COMMON.INTERACT'
7578 !      include 'COMMON.CONTACTS'
7579 !      include 'COMMON.CHAIN'
7580 !      include 'COMMON.CONTROL'
7581       real(kind=8),dimension(3) :: gx,gx1
7582       integer,dimension(nres) :: num_cont_hb_old
7583       logical :: lprn,ldone
7584 !EL      double precision eello4,eello5,eelo6,eello_turn6
7585 !EL      external eello4,eello5,eello6,eello_turn6
7586 !el local variables
7587       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7588               j1,jp1,i1,num_conti1
7589       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7590       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7591
7592 ! Set lprn=.true. for debugging
7593       lprn=.false.
7594       eturn6=0.0d0
7595 #ifdef MPI
7596 !      maxconts=nres/4
7597       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7598       do i=1,nres
7599         num_cont_hb_old(i)=num_cont_hb(i)
7600       enddo
7601       n_corr=0
7602       n_corr1=0
7603       if (nfgtasks.le.1) goto 30
7604       if (lprn) then
7605         write (iout,'(a)') 'Contact function values before RECEIVE:'
7606         do i=nnt,nct-2
7607           write (iout,'(2i3,50(1x,i2,f5.2))') &
7608           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7609           j=1,num_cont_hb(i))
7610         enddo
7611       endif
7612       call flush(iout)
7613       do i=1,ntask_cont_from
7614         ncont_recv(i)=0
7615       enddo
7616       do i=1,ntask_cont_to
7617         ncont_sent(i)=0
7618       enddo
7619 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7620 !     & ntask_cont_to
7621 ! Make the list of contacts to send to send to other procesors
7622       do i=iturn3_start,iturn3_end
7623 !        write (iout,*) "make contact list turn3",i," num_cont",
7624 !     &    num_cont_hb(i)
7625         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7626       enddo
7627       do i=iturn4_start,iturn4_end
7628 !        write (iout,*) "make contact list turn4",i," num_cont",
7629 !     &   num_cont_hb(i)
7630         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7631       enddo
7632       do ii=1,nat_sent
7633         i=iat_sent(ii)
7634 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7635 !     &    num_cont_hb(i)
7636         do j=1,num_cont_hb(i)
7637         do k=1,4
7638           jjc=jcont_hb(j,i)
7639           iproc=iint_sent_local(k,jjc,ii)
7640 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7641           if (iproc.ne.0) then
7642             ncont_sent(iproc)=ncont_sent(iproc)+1
7643             nn=ncont_sent(iproc)
7644             zapas(1,nn,iproc)=i
7645             zapas(2,nn,iproc)=jjc
7646             zapas(3,nn,iproc)=d_cont(j,i)
7647             ind=3
7648             do kk=1,3
7649               ind=ind+1
7650               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7651             enddo
7652             do kk=1,2
7653               do ll=1,2
7654                 ind=ind+1
7655                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7656               enddo
7657             enddo
7658             do jj=1,5
7659               do kk=1,3
7660                 do ll=1,2
7661                   do mm=1,2
7662                     ind=ind+1
7663                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7664                   enddo
7665                 enddo
7666               enddo
7667             enddo
7668           endif
7669         enddo
7670         enddo
7671       enddo
7672       if (lprn) then
7673       write (iout,*) &
7674         "Numbers of contacts to be sent to other processors",&
7675         (ncont_sent(i),i=1,ntask_cont_to)
7676       write (iout,*) "Contacts sent"
7677       do ii=1,ntask_cont_to
7678         nn=ncont_sent(ii)
7679         iproc=itask_cont_to(ii)
7680         write (iout,*) nn," contacts to processor",iproc,&
7681          " of CONT_TO_COMM group"
7682         do i=1,nn
7683           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7684         enddo
7685       enddo
7686       call flush(iout)
7687       endif
7688       CorrelType=477
7689       CorrelID=fg_rank+1
7690       CorrelType1=478
7691       CorrelID1=nfgtasks+fg_rank+1
7692       ireq=0
7693 ! Receive the numbers of needed contacts from other processors
7694       do ii=1,ntask_cont_from
7695         iproc=itask_cont_from(ii)
7696         ireq=ireq+1
7697         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7698           FG_COMM,req(ireq),IERR)
7699       enddo
7700 !      write (iout,*) "IRECV ended"
7701 !      call flush(iout)
7702 ! Send the number of contacts needed by other processors
7703       do ii=1,ntask_cont_to
7704         iproc=itask_cont_to(ii)
7705         ireq=ireq+1
7706         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7707           FG_COMM,req(ireq),IERR)
7708       enddo
7709 !      write (iout,*) "ISEND ended"
7710 !      write (iout,*) "number of requests (nn)",ireq
7711       call flush(iout)
7712       if (ireq.gt.0) &
7713         call MPI_Waitall(ireq,req,status_array,ierr)
7714 !      write (iout,*)
7715 !     &  "Numbers of contacts to be received from other processors",
7716 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7717 !      call flush(iout)
7718 ! Receive contacts
7719       ireq=0
7720       do ii=1,ntask_cont_from
7721         iproc=itask_cont_from(ii)
7722         nn=ncont_recv(ii)
7723 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7724 !     &   " of CONT_TO_COMM group"
7725         call flush(iout)
7726         if (nn.gt.0) then
7727           ireq=ireq+1
7728           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7729           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7730 !          write (iout,*) "ireq,req",ireq,req(ireq)
7731         endif
7732       enddo
7733 ! Send the contacts to processors that need them
7734       do ii=1,ntask_cont_to
7735         iproc=itask_cont_to(ii)
7736         nn=ncont_sent(ii)
7737 !        write (iout,*) nn," contacts to processor",iproc,
7738 !     &   " of CONT_TO_COMM group"
7739         if (nn.gt.0) then
7740           ireq=ireq+1
7741           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7742             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7743 !          write (iout,*) "ireq,req",ireq,req(ireq)
7744 !          do i=1,nn
7745 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7746 !          enddo
7747         endif
7748       enddo
7749 !      write (iout,*) "number of requests (contacts)",ireq
7750 !      write (iout,*) "req",(req(i),i=1,4)
7751 !      call flush(iout)
7752       if (ireq.gt.0) &
7753        call MPI_Waitall(ireq,req,status_array,ierr)
7754       do iii=1,ntask_cont_from
7755         iproc=itask_cont_from(iii)
7756         nn=ncont_recv(iii)
7757         if (lprn) then
7758         write (iout,*) "Received",nn," contacts from processor",iproc,&
7759          " of CONT_FROM_COMM group"
7760         call flush(iout)
7761         do i=1,nn
7762           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7763         enddo
7764         call flush(iout)
7765         endif
7766         do i=1,nn
7767           ii=zapas_recv(1,i,iii)
7768 ! Flag the received contacts to prevent double-counting
7769           jj=-zapas_recv(2,i,iii)
7770 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7771 !          call flush(iout)
7772           nnn=num_cont_hb(ii)+1
7773           num_cont_hb(ii)=nnn
7774           jcont_hb(nnn,ii)=jj
7775           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7776           ind=3
7777           do kk=1,3
7778             ind=ind+1
7779             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7780           enddo
7781           do kk=1,2
7782             do ll=1,2
7783               ind=ind+1
7784               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7785             enddo
7786           enddo
7787           do jj=1,5
7788             do kk=1,3
7789               do ll=1,2
7790                 do mm=1,2
7791                   ind=ind+1
7792                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7793                 enddo
7794               enddo
7795             enddo
7796           enddo
7797         enddo
7798       enddo
7799       call flush(iout)
7800       if (lprn) then
7801         write (iout,'(a)') 'Contact function values after receive:'
7802         do i=nnt,nct-2
7803           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7804           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7805           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7806         enddo
7807         call flush(iout)
7808       endif
7809    30 continue
7810 #endif
7811       if (lprn) then
7812         write (iout,'(a)') 'Contact function values:'
7813         do i=nnt,nct-2
7814           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7815           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7816           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7817         enddo
7818       endif
7819       ecorr=0.0D0
7820       ecorr5=0.0d0
7821       ecorr6=0.0d0
7822
7823 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7824 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7825 ! Remove the loop below after debugging !!!
7826       do i=nnt,nct
7827         do j=1,3
7828           gradcorr(j,i)=0.0D0
7829           gradxorr(j,i)=0.0D0
7830         enddo
7831       enddo
7832 ! Calculate the dipole-dipole interaction energies
7833       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7834       do i=iatel_s,iatel_e+1
7835         num_conti=num_cont_hb(i)
7836         do jj=1,num_conti
7837           j=jcont_hb(jj,i)
7838 #ifdef MOMENT
7839           call dipole(i,j,jj)
7840 #endif
7841         enddo
7842       enddo
7843       endif
7844 ! Calculate the local-electrostatic correlation terms
7845 !                write (iout,*) "gradcorr5 in eello5 before loop"
7846 !                do iii=1,nres
7847 !                  write (iout,'(i5,3f10.5)')
7848 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7849 !                enddo
7850       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7851 !        write (iout,*) "corr loop i",i
7852         i1=i+1
7853         num_conti=num_cont_hb(i)
7854         num_conti1=num_cont_hb(i+1)
7855         do jj=1,num_conti
7856           j=jcont_hb(jj,i)
7857           jp=iabs(j)
7858           do kk=1,num_conti1
7859             j1=jcont_hb(kk,i1)
7860             jp1=iabs(j1)
7861 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7862 !     &         ' jj=',jj,' kk=',kk
7863 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7864             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7865                 .or. j.lt.0 .and. j1.gt.0) .and. &
7866                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7867 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7868 ! The system gains extra energy.
7869               n_corr=n_corr+1
7870               sqd1=dsqrt(d_cont(jj,i))
7871               sqd2=dsqrt(d_cont(kk,i1))
7872               sred_geom = sqd1*sqd2
7873               IF (sred_geom.lt.cutoff_corr) THEN
7874                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7875                   ekont,fprimcont)
7876 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7877 !d     &         ' jj=',jj,' kk=',kk
7878                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7879                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7880                 do l=1,3
7881                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7882                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7883                 enddo
7884                 n_corr1=n_corr1+1
7885 !d               write (iout,*) 'sred_geom=',sred_geom,
7886 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7887 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7888 !d               write (iout,*) "g_contij",g_contij
7889 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7890 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7891                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7892                 if (wcorr4.gt.0.0d0) &
7893                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7894                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7895                        write (iout,'(a6,4i5,0pf7.3)') &
7896                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7897 !                write (iout,*) "gradcorr5 before eello5"
7898 !                do iii=1,nres
7899 !                  write (iout,'(i5,3f10.5)')
7900 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7901 !                enddo
7902                 if (wcorr5.gt.0.0d0) &
7903                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7904 !                write (iout,*) "gradcorr5 after eello5"
7905 !                do iii=1,nres
7906 !                  write (iout,'(i5,3f10.5)')
7907 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7908 !                enddo
7909                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7910                        write (iout,'(a6,4i5,0pf7.3)') &
7911                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7912 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7913 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7914                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7915                      .or. wturn6.eq.0.0d0))then
7916 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7917                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7918                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7919                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7920 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7921 !d     &            'ecorr6=',ecorr6
7922 !d                write (iout,'(4e15.5)') sred_geom,
7923 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7924 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7925 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7926                 else if (wturn6.gt.0.0d0 &
7927                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7928 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7929                   eturn6=eturn6+eello_turn6(i,jj,kk)
7930                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7931                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7932 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7933                 endif
7934               ENDIF
7935 1111          continue
7936             endif
7937           enddo ! kk
7938         enddo ! jj
7939       enddo ! i
7940       do i=1,nres
7941         num_cont_hb(i)=num_cont_hb_old(i)
7942       enddo
7943 !                write (iout,*) "gradcorr5 in eello5"
7944 !                do iii=1,nres
7945 !                  write (iout,'(i5,3f10.5)')
7946 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7947 !                enddo
7948       return
7949       end subroutine multibody_eello
7950 !-----------------------------------------------------------------------------
7951       subroutine add_hb_contact_eello(ii,jj,itask)
7952 !      implicit real*8 (a-h,o-z)
7953 !      include "DIMENSIONS"
7954 !      include "COMMON.IOUNITS"
7955 !      include "COMMON.CONTACTS"
7956 !      integer,parameter :: maxconts=nres/4
7957       integer,parameter :: max_dim=70
7958       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7959 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7960 !      common /przechowalnia/ zapas
7961
7962       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7963       integer,dimension(4) ::itask
7964 !      write (iout,*) "itask",itask
7965       do i=1,2
7966         iproc=itask(i)
7967         if (iproc.gt.0) then
7968           do j=1,num_cont_hb(ii)
7969             jjc=jcont_hb(j,ii)
7970 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7971             if (jjc.eq.jj) then
7972               ncont_sent(iproc)=ncont_sent(iproc)+1
7973               nn=ncont_sent(iproc)
7974               zapas(1,nn,iproc)=ii
7975               zapas(2,nn,iproc)=jjc
7976               zapas(3,nn,iproc)=d_cont(j,ii)
7977               ind=3
7978               do kk=1,3
7979                 ind=ind+1
7980                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7981               enddo
7982               do kk=1,2
7983                 do ll=1,2
7984                   ind=ind+1
7985                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7986                 enddo
7987               enddo
7988               do jj=1,5
7989                 do kk=1,3
7990                   do ll=1,2
7991                     do mm=1,2
7992                       ind=ind+1
7993                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7994                     enddo
7995                   enddo
7996                 enddo
7997               enddo
7998               exit
7999             endif
8000           enddo
8001         endif
8002       enddo
8003       return
8004       end subroutine add_hb_contact_eello
8005 !-----------------------------------------------------------------------------
8006       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8007 !      implicit real*8 (a-h,o-z)
8008 !      include 'DIMENSIONS'
8009 !      include 'COMMON.IOUNITS'
8010 !      include 'COMMON.DERIV'
8011 !      include 'COMMON.INTERACT'
8012 !      include 'COMMON.CONTACTS'
8013       real(kind=8),dimension(3) :: gx,gx1
8014       logical :: lprn
8015 !el local variables
8016       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8017       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8018                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8019                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8020                    rlocshield
8021
8022       lprn=.false.
8023       eij=facont_hb(jj,i)
8024       ekl=facont_hb(kk,k)
8025       ees0pij=ees0p(jj,i)
8026       ees0pkl=ees0p(kk,k)
8027       ees0mij=ees0m(jj,i)
8028       ees0mkl=ees0m(kk,k)
8029       ekont=eij*ekl
8030       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8031 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8032 ! Following 4 lines for diagnostics.
8033 !d    ees0pkl=0.0D0
8034 !d    ees0pij=1.0D0
8035 !d    ees0mkl=0.0D0
8036 !d    ees0mij=1.0D0
8037 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8038 !     & 'Contacts ',i,j,
8039 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8040 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8041 !     & 'gradcorr_long'
8042 ! Calculate the multi-body contribution to energy.
8043 !      ecorr=ecorr+ekont*ees
8044 ! Calculate multi-body contributions to the gradient.
8045       coeffpees0pij=coeffp*ees0pij
8046       coeffmees0mij=coeffm*ees0mij
8047       coeffpees0pkl=coeffp*ees0pkl
8048       coeffmees0mkl=coeffm*ees0mkl
8049       do ll=1,3
8050 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8051         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8052         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8053         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8054         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8055         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8056         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8057 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8058         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8059         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8060         coeffmees0mij*gacontm_hb1(ll,kk,k))
8061         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8062         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8063         coeffmees0mij*gacontm_hb2(ll,kk,k))
8064         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8065            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8066            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8067         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8068         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8069         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8070            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8071            coeffmees0mij*gacontm_hb3(ll,kk,k))
8072         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8073         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8074 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8075       enddo
8076 !      write (iout,*)
8077 !grad      do m=i+1,j-1
8078 !grad        do ll=1,3
8079 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8080 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8081 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8082 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8083 !grad        enddo
8084 !grad      enddo
8085 !grad      do m=k+1,l-1
8086 !grad        do ll=1,3
8087 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8088 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8089 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8090 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8091 !grad        enddo
8092 !grad      enddo
8093 !      write (iout,*) "ehbcorr",ekont*ees
8094       ehbcorr=ekont*ees
8095       if (shield_mode.gt.0) then
8096        j=ees0plist(jj,i)
8097        l=ees0plist(kk,k)
8098 !C        print *,i,j,fac_shield(i),fac_shield(j),
8099 !C     &fac_shield(k),fac_shield(l)
8100         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8101            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8102           do ilist=1,ishield_list(i)
8103            iresshield=shield_list(ilist,i)
8104            do m=1,3
8105            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8106            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8107                    rlocshield  &
8108             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8109             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8110             +rlocshield
8111            enddo
8112           enddo
8113           do ilist=1,ishield_list(j)
8114            iresshield=shield_list(ilist,j)
8115            do m=1,3
8116            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8117            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8118                    rlocshield &
8119             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8120            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8121             +rlocshield
8122            enddo
8123           enddo
8124
8125           do ilist=1,ishield_list(k)
8126            iresshield=shield_list(ilist,k)
8127            do m=1,3
8128            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8129            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8130                    rlocshield &
8131             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8132            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8133             +rlocshield
8134            enddo
8135           enddo
8136           do ilist=1,ishield_list(l)
8137            iresshield=shield_list(ilist,l)
8138            do m=1,3
8139            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8140            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8141                    rlocshield &
8142             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8143            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8144             +rlocshield
8145            enddo
8146           enddo
8147           do m=1,3
8148             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8149                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8150             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8151                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8152             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8153                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8154             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8155                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8156
8157             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8158                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8159             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8160                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8161             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8162                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8163             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8164                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8165
8166            enddo
8167       endif
8168       endif
8169       return
8170       end function ehbcorr
8171 #ifdef MOMENT
8172 !-----------------------------------------------------------------------------
8173       subroutine dipole(i,j,jj)
8174 !      implicit real*8 (a-h,o-z)
8175 !      include 'DIMENSIONS'
8176 !      include 'COMMON.IOUNITS'
8177 !      include 'COMMON.CHAIN'
8178 !      include 'COMMON.FFIELD'
8179 !      include 'COMMON.DERIV'
8180 !      include 'COMMON.INTERACT'
8181 !      include 'COMMON.CONTACTS'
8182 !      include 'COMMON.TORSION'
8183 !      include 'COMMON.VAR'
8184 !      include 'COMMON.GEO'
8185       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8186       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8187       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8188
8189       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8190       allocate(dipderx(3,5,4,maxconts,nres))
8191 !
8192
8193       iti1 = itortyp(itype(i+1,1))
8194       if (j.lt.nres-1) then
8195         itj1 = itortyp(itype(j+1,1))
8196       else
8197         itj1=ntortyp+1
8198       endif
8199       do iii=1,2
8200         dipi(iii,1)=Ub2(iii,i)
8201         dipderi(iii)=Ub2der(iii,i)
8202         dipi(iii,2)=b1(iii,iti1)
8203         dipj(iii,1)=Ub2(iii,j)
8204         dipderj(iii)=Ub2der(iii,j)
8205         dipj(iii,2)=b1(iii,itj1)
8206       enddo
8207       kkk=0
8208       do iii=1,2
8209         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8210         do jjj=1,2
8211           kkk=kkk+1
8212           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8213         enddo
8214       enddo
8215       do kkk=1,5
8216         do lll=1,3
8217           mmm=0
8218           do iii=1,2
8219             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8220               auxvec(1))
8221             do jjj=1,2
8222               mmm=mmm+1
8223               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8224             enddo
8225           enddo
8226         enddo
8227       enddo
8228       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8229       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8230       do iii=1,2
8231         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8232       enddo
8233       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8234       do iii=1,2
8235         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8236       enddo
8237       return
8238       end subroutine dipole
8239 #endif
8240 !-----------------------------------------------------------------------------
8241       subroutine calc_eello(i,j,k,l,jj,kk)
8242 !
8243 ! This subroutine computes matrices and vectors needed to calculate
8244 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8245 !
8246       use comm_kut
8247 !      implicit real*8 (a-h,o-z)
8248 !      include 'DIMENSIONS'
8249 !      include 'COMMON.IOUNITS'
8250 !      include 'COMMON.CHAIN'
8251 !      include 'COMMON.DERIV'
8252 !      include 'COMMON.INTERACT'
8253 !      include 'COMMON.CONTACTS'
8254 !      include 'COMMON.TORSION'
8255 !      include 'COMMON.VAR'
8256 !      include 'COMMON.GEO'
8257 !      include 'COMMON.FFIELD'
8258       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8259       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8260       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8261               itj1
8262 !el      logical :: lprn
8263 !el      common /kutas/ lprn
8264 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8265 !d     & ' jj=',jj,' kk=',kk
8266 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8267 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8268 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8269       do iii=1,2
8270         do jjj=1,2
8271           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8272           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8273         enddo
8274       enddo
8275       call transpose2(aa1(1,1),aa1t(1,1))
8276       call transpose2(aa2(1,1),aa2t(1,1))
8277       do kkk=1,5
8278         do lll=1,3
8279           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8280             aa1tder(1,1,lll,kkk))
8281           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8282             aa2tder(1,1,lll,kkk))
8283         enddo
8284       enddo
8285       if (l.eq.j+1) then
8286 ! parallel orientation of the two CA-CA-CA frames.
8287         if (i.gt.1) then
8288           iti=itortyp(itype(i,1))
8289         else
8290           iti=ntortyp+1
8291         endif
8292         itk1=itortyp(itype(k+1,1))
8293         itj=itortyp(itype(j,1))
8294         if (l.lt.nres-1) then
8295           itl1=itortyp(itype(l+1,1))
8296         else
8297           itl1=ntortyp+1
8298         endif
8299 ! A1 kernel(j+1) A2T
8300 !d        do iii=1,2
8301 !d          write (iout,'(3f10.5,5x,3f10.5)')
8302 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8303 !d        enddo
8304         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8305          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8306          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8307 ! Following matrices are needed only for 6-th order cumulants
8308         IF (wcorr6.gt.0.0d0) THEN
8309         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8310          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8311          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8312         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8313          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8314          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8315          ADtEAderx(1,1,1,1,1,1))
8316         lprn=.false.
8317         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8318          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8319          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8320          ADtEA1derx(1,1,1,1,1,1))
8321         ENDIF
8322 ! End 6-th order cumulants
8323 !d        lprn=.false.
8324 !d        if (lprn) then
8325 !d        write (2,*) 'In calc_eello6'
8326 !d        do iii=1,2
8327 !d          write (2,*) 'iii=',iii
8328 !d          do kkk=1,5
8329 !d            write (2,*) 'kkk=',kkk
8330 !d            do jjj=1,2
8331 !d              write (2,'(3(2f10.5),5x)')
8332 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8333 !d            enddo
8334 !d          enddo
8335 !d        enddo
8336 !d        endif
8337         call transpose2(EUgder(1,1,k),auxmat(1,1))
8338         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8339         call transpose2(EUg(1,1,k),auxmat(1,1))
8340         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8341         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8342         do iii=1,2
8343           do kkk=1,5
8344             do lll=1,3
8345               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8346                 EAEAderx(1,1,lll,kkk,iii,1))
8347             enddo
8348           enddo
8349         enddo
8350 ! A1T kernel(i+1) A2
8351         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8352          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8353          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8354 ! Following matrices are needed only for 6-th order cumulants
8355         IF (wcorr6.gt.0.0d0) THEN
8356         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8357          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8358          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8359         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8360          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8361          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8362          ADtEAderx(1,1,1,1,1,2))
8363         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8364          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8365          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8366          ADtEA1derx(1,1,1,1,1,2))
8367         ENDIF
8368 ! End 6-th order cumulants
8369         call transpose2(EUgder(1,1,l),auxmat(1,1))
8370         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8371         call transpose2(EUg(1,1,l),auxmat(1,1))
8372         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8373         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8374         do iii=1,2
8375           do kkk=1,5
8376             do lll=1,3
8377               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8378                 EAEAderx(1,1,lll,kkk,iii,2))
8379             enddo
8380           enddo
8381         enddo
8382 ! AEAb1 and AEAb2
8383 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8384 ! They are needed only when the fifth- or the sixth-order cumulants are
8385 ! indluded.
8386         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8387         call transpose2(AEA(1,1,1),auxmat(1,1))
8388         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8389         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8390         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8391         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8392         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8393         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8394         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8395         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8396         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8397         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8398         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8399         call transpose2(AEA(1,1,2),auxmat(1,1))
8400         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8401         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8402         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8403         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8404         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8405         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8406         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8407         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8408         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8409         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8410         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8411 ! Calculate the Cartesian derivatives of the vectors.
8412         do iii=1,2
8413           do kkk=1,5
8414             do lll=1,3
8415               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8416               call matvec2(auxmat(1,1),b1(1,iti),&
8417                 AEAb1derx(1,lll,kkk,iii,1,1))
8418               call matvec2(auxmat(1,1),Ub2(1,i),&
8419                 AEAb2derx(1,lll,kkk,iii,1,1))
8420               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8421                 AEAb1derx(1,lll,kkk,iii,2,1))
8422               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8423                 AEAb2derx(1,lll,kkk,iii,2,1))
8424               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8425               call matvec2(auxmat(1,1),b1(1,itj),&
8426                 AEAb1derx(1,lll,kkk,iii,1,2))
8427               call matvec2(auxmat(1,1),Ub2(1,j),&
8428                 AEAb2derx(1,lll,kkk,iii,1,2))
8429               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8430                 AEAb1derx(1,lll,kkk,iii,2,2))
8431               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8432                 AEAb2derx(1,lll,kkk,iii,2,2))
8433             enddo
8434           enddo
8435         enddo
8436         ENDIF
8437 ! End vectors
8438       else
8439 ! Antiparallel orientation of the two CA-CA-CA frames.
8440         if (i.gt.1) then
8441           iti=itortyp(itype(i,1))
8442         else
8443           iti=ntortyp+1
8444         endif
8445         itk1=itortyp(itype(k+1,1))
8446         itl=itortyp(itype(l,1))
8447         itj=itortyp(itype(j,1))
8448         if (j.lt.nres-1) then
8449           itj1=itortyp(itype(j+1,1))
8450         else
8451           itj1=ntortyp+1
8452         endif
8453 ! A2 kernel(j-1)T A1T
8454         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8455          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8456          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8457 ! Following matrices are needed only for 6-th order cumulants
8458         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8459            j.eq.i+4 .and. l.eq.i+3)) THEN
8460         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8461          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8462          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8463         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8464          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8465          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8466          ADtEAderx(1,1,1,1,1,1))
8467         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8468          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8469          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8470          ADtEA1derx(1,1,1,1,1,1))
8471         ENDIF
8472 ! End 6-th order cumulants
8473         call transpose2(EUgder(1,1,k),auxmat(1,1))
8474         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8475         call transpose2(EUg(1,1,k),auxmat(1,1))
8476         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8477         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8478         do iii=1,2
8479           do kkk=1,5
8480             do lll=1,3
8481               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8482                 EAEAderx(1,1,lll,kkk,iii,1))
8483             enddo
8484           enddo
8485         enddo
8486 ! A2T kernel(i+1)T A1
8487         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8488          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8489          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8490 ! Following matrices are needed only for 6-th order cumulants
8491         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8492            j.eq.i+4 .and. l.eq.i+3)) THEN
8493         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8494          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8495          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8496         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8497          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8498          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8499          ADtEAderx(1,1,1,1,1,2))
8500         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8501          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8502          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8503          ADtEA1derx(1,1,1,1,1,2))
8504         ENDIF
8505 ! End 6-th order cumulants
8506         call transpose2(EUgder(1,1,j),auxmat(1,1))
8507         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8508         call transpose2(EUg(1,1,j),auxmat(1,1))
8509         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8510         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8511         do iii=1,2
8512           do kkk=1,5
8513             do lll=1,3
8514               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8515                 EAEAderx(1,1,lll,kkk,iii,2))
8516             enddo
8517           enddo
8518         enddo
8519 ! AEAb1 and AEAb2
8520 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8521 ! They are needed only when the fifth- or the sixth-order cumulants are
8522 ! indluded.
8523         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8524           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8525         call transpose2(AEA(1,1,1),auxmat(1,1))
8526         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8527         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8528         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8529         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8530         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8531         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8532         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8533         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8534         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8535         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8536         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8537         call transpose2(AEA(1,1,2),auxmat(1,1))
8538         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8539         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8540         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8541         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8542         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8543         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8544         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8545         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8546         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8547         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8548         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8549 ! Calculate the Cartesian derivatives of the vectors.
8550         do iii=1,2
8551           do kkk=1,5
8552             do lll=1,3
8553               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8554               call matvec2(auxmat(1,1),b1(1,iti),&
8555                 AEAb1derx(1,lll,kkk,iii,1,1))
8556               call matvec2(auxmat(1,1),Ub2(1,i),&
8557                 AEAb2derx(1,lll,kkk,iii,1,1))
8558               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8559                 AEAb1derx(1,lll,kkk,iii,2,1))
8560               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8561                 AEAb2derx(1,lll,kkk,iii,2,1))
8562               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8563               call matvec2(auxmat(1,1),b1(1,itl),&
8564                 AEAb1derx(1,lll,kkk,iii,1,2))
8565               call matvec2(auxmat(1,1),Ub2(1,l),&
8566                 AEAb2derx(1,lll,kkk,iii,1,2))
8567               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8568                 AEAb1derx(1,lll,kkk,iii,2,2))
8569               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8570                 AEAb2derx(1,lll,kkk,iii,2,2))
8571             enddo
8572           enddo
8573         enddo
8574         ENDIF
8575 ! End vectors
8576       endif
8577       return
8578       end subroutine calc_eello
8579 !-----------------------------------------------------------------------------
8580       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8581       use comm_kut
8582       implicit none
8583       integer :: nderg
8584       logical :: transp
8585       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8586       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8587       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8588       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8589       integer :: iii,kkk,lll
8590       integer :: jjj,mmm
8591 !el      logical :: lprn
8592 !el      common /kutas/ lprn
8593       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8594       do iii=1,nderg
8595         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8596           AKAderg(1,1,iii))
8597       enddo
8598 !d      if (lprn) write (2,*) 'In kernel'
8599       do kkk=1,5
8600 !d        if (lprn) write (2,*) 'kkk=',kkk
8601         do lll=1,3
8602           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8603             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8604 !d          if (lprn) then
8605 !d            write (2,*) 'lll=',lll
8606 !d            write (2,*) 'iii=1'
8607 !d            do jjj=1,2
8608 !d              write (2,'(3(2f10.5),5x)')
8609 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8610 !d            enddo
8611 !d          endif
8612           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8613             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8614 !d          if (lprn) then
8615 !d            write (2,*) 'lll=',lll
8616 !d            write (2,*) 'iii=2'
8617 !d            do jjj=1,2
8618 !d              write (2,'(3(2f10.5),5x)')
8619 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8620 !d            enddo
8621 !d          endif
8622         enddo
8623       enddo
8624       return
8625       end subroutine kernel
8626 !-----------------------------------------------------------------------------
8627       real(kind=8) function eello4(i,j,k,l,jj,kk)
8628 !      implicit real*8 (a-h,o-z)
8629 !      include 'DIMENSIONS'
8630 !      include 'COMMON.IOUNITS'
8631 !      include 'COMMON.CHAIN'
8632 !      include 'COMMON.DERIV'
8633 !      include 'COMMON.INTERACT'
8634 !      include 'COMMON.CONTACTS'
8635 !      include 'COMMON.TORSION'
8636 !      include 'COMMON.VAR'
8637 !      include 'COMMON.GEO'
8638       real(kind=8),dimension(2,2) :: pizda
8639       real(kind=8),dimension(3) :: ggg1,ggg2
8640       real(kind=8) ::  eel4,glongij,glongkl
8641       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8642 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8643 !d        eello4=0.0d0
8644 !d        return
8645 !d      endif
8646 !d      print *,'eello4:',i,j,k,l,jj,kk
8647 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8648 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8649 !old      eij=facont_hb(jj,i)
8650 !old      ekl=facont_hb(kk,k)
8651 !old      ekont=eij*ekl
8652       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8653 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8654       gcorr_loc(k-1)=gcorr_loc(k-1) &
8655          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8656       if (l.eq.j+1) then
8657         gcorr_loc(l-1)=gcorr_loc(l-1) &
8658            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8659       else
8660         gcorr_loc(j-1)=gcorr_loc(j-1) &
8661            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8662       endif
8663       do iii=1,2
8664         do kkk=1,5
8665           do lll=1,3
8666             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8667                               -EAEAderx(2,2,lll,kkk,iii,1)
8668 !d            derx(lll,kkk,iii)=0.0d0
8669           enddo
8670         enddo
8671       enddo
8672 !d      gcorr_loc(l-1)=0.0d0
8673 !d      gcorr_loc(j-1)=0.0d0
8674 !d      gcorr_loc(k-1)=0.0d0
8675 !d      eel4=1.0d0
8676 !d      write (iout,*)'Contacts have occurred for peptide groups',
8677 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8678 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8679       if (j.lt.nres-1) then
8680         j1=j+1
8681         j2=j-1
8682       else
8683         j1=j-1
8684         j2=j-2
8685       endif
8686       if (l.lt.nres-1) then
8687         l1=l+1
8688         l2=l-1
8689       else
8690         l1=l-1
8691         l2=l-2
8692       endif
8693       do ll=1,3
8694 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8695 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8696         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8697         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8698 !grad        ghalf=0.5d0*ggg1(ll)
8699         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8700         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8701         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8702         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8703         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8704         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8705 !grad        ghalf=0.5d0*ggg2(ll)
8706         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8707         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8708         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8709         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8710         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8711         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8712       enddo
8713 !grad      do m=i+1,j-1
8714 !grad        do ll=1,3
8715 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8716 !grad        enddo
8717 !grad      enddo
8718 !grad      do m=k+1,l-1
8719 !grad        do ll=1,3
8720 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8721 !grad        enddo
8722 !grad      enddo
8723 !grad      do m=i+2,j2
8724 !grad        do ll=1,3
8725 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8726 !grad        enddo
8727 !grad      enddo
8728 !grad      do m=k+2,l2
8729 !grad        do ll=1,3
8730 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8731 !grad        enddo
8732 !grad      enddo
8733 !d      do iii=1,nres-3
8734 !d        write (2,*) iii,gcorr_loc(iii)
8735 !d      enddo
8736       eello4=ekont*eel4
8737 !d      write (2,*) 'ekont',ekont
8738 !d      write (iout,*) 'eello4',ekont*eel4
8739       return
8740       end function eello4
8741 !-----------------------------------------------------------------------------
8742       real(kind=8) function eello5(i,j,k,l,jj,kk)
8743 !      implicit real*8 (a-h,o-z)
8744 !      include 'DIMENSIONS'
8745 !      include 'COMMON.IOUNITS'
8746 !      include 'COMMON.CHAIN'
8747 !      include 'COMMON.DERIV'
8748 !      include 'COMMON.INTERACT'
8749 !      include 'COMMON.CONTACTS'
8750 !      include 'COMMON.TORSION'
8751 !      include 'COMMON.VAR'
8752 !      include 'COMMON.GEO'
8753       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8754       real(kind=8),dimension(2) :: vv
8755       real(kind=8),dimension(3) :: ggg1,ggg2
8756       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8757       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8758       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8759 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8760 !                                                                              C
8761 !                            Parallel chains                                   C
8762 !                                                                              C
8763 !          o             o                   o             o                   C
8764 !         /l\           / \             \   / \           / \   /              C
8765 !        /   \         /   \             \ /   \         /   \ /               C
8766 !       j| o |l1       | o |                o| o |         | o |o                C
8767 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8768 !      \i/   \         /   \ /             /   \         /   \                 C
8769 !       o    k1             o                                                  C
8770 !         (I)          (II)                (III)          (IV)                 C
8771 !                                                                              C
8772 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8773 !                                                                              C
8774 !                            Antiparallel chains                               C
8775 !                                                                              C
8776 !          o             o                   o             o                   C
8777 !         /j\           / \             \   / \           / \   /              C
8778 !        /   \         /   \             \ /   \         /   \ /               C
8779 !      j1| o |l        | o |                o| o |         | o |o                C
8780 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8781 !      \i/   \         /   \ /             /   \         /   \                 C
8782 !       o     k1            o                                                  C
8783 !         (I)          (II)                (III)          (IV)                 C
8784 !                                                                              C
8785 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8786 !                                                                              C
8787 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8788 !                                                                              C
8789 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8790 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8791 !d        eello5=0.0d0
8792 !d        return
8793 !d      endif
8794 !d      write (iout,*)
8795 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8796 !d     &   ' and',k,l
8797       itk=itortyp(itype(k,1))
8798       itl=itortyp(itype(l,1))
8799       itj=itortyp(itype(j,1))
8800       eello5_1=0.0d0
8801       eello5_2=0.0d0
8802       eello5_3=0.0d0
8803       eello5_4=0.0d0
8804 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8805 !d     &   eel5_3_num,eel5_4_num)
8806       do iii=1,2
8807         do kkk=1,5
8808           do lll=1,3
8809             derx(lll,kkk,iii)=0.0d0
8810           enddo
8811         enddo
8812       enddo
8813 !d      eij=facont_hb(jj,i)
8814 !d      ekl=facont_hb(kk,k)
8815 !d      ekont=eij*ekl
8816 !d      write (iout,*)'Contacts have occurred for peptide groups',
8817 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8818 !d      goto 1111
8819 ! Contribution from the graph I.
8820 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8821 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8822       call transpose2(EUg(1,1,k),auxmat(1,1))
8823       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8824       vv(1)=pizda(1,1)-pizda(2,2)
8825       vv(2)=pizda(1,2)+pizda(2,1)
8826       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8827        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8828 ! Explicit gradient in virtual-dihedral angles.
8829       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8830        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8831        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8832       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8833       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8834       vv(1)=pizda(1,1)-pizda(2,2)
8835       vv(2)=pizda(1,2)+pizda(2,1)
8836       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8837        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8838        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8839       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8840       vv(1)=pizda(1,1)-pizda(2,2)
8841       vv(2)=pizda(1,2)+pizda(2,1)
8842       if (l.eq.j+1) then
8843         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8844          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8845          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8846       else
8847         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8848          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8849          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8850       endif
8851 ! Cartesian gradient
8852       do iii=1,2
8853         do kkk=1,5
8854           do lll=1,3
8855             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8856               pizda(1,1))
8857             vv(1)=pizda(1,1)-pizda(2,2)
8858             vv(2)=pizda(1,2)+pizda(2,1)
8859             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8860              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8861              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8862           enddo
8863         enddo
8864       enddo
8865 !      goto 1112
8866 !1111  continue
8867 ! Contribution from graph II
8868       call transpose2(EE(1,1,itk),auxmat(1,1))
8869       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8870       vv(1)=pizda(1,1)+pizda(2,2)
8871       vv(2)=pizda(2,1)-pizda(1,2)
8872       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8873        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8874 ! Explicit gradient in virtual-dihedral angles.
8875       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8876        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8877       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8878       vv(1)=pizda(1,1)+pizda(2,2)
8879       vv(2)=pizda(2,1)-pizda(1,2)
8880       if (l.eq.j+1) then
8881         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8882          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8883          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8884       else
8885         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8886          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8887          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8888       endif
8889 ! Cartesian gradient
8890       do iii=1,2
8891         do kkk=1,5
8892           do lll=1,3
8893             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8894               pizda(1,1))
8895             vv(1)=pizda(1,1)+pizda(2,2)
8896             vv(2)=pizda(2,1)-pizda(1,2)
8897             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8898              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8899              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8900           enddo
8901         enddo
8902       enddo
8903 !d      goto 1112
8904 !d1111  continue
8905       if (l.eq.j+1) then
8906 !d        goto 1110
8907 ! Parallel orientation
8908 ! Contribution from graph III
8909         call transpose2(EUg(1,1,l),auxmat(1,1))
8910         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8911         vv(1)=pizda(1,1)-pizda(2,2)
8912         vv(2)=pizda(1,2)+pizda(2,1)
8913         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8914          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8915 ! Explicit gradient in virtual-dihedral angles.
8916         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8917          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8918          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8919         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8920         vv(1)=pizda(1,1)-pizda(2,2)
8921         vv(2)=pizda(1,2)+pizda(2,1)
8922         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8923          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8924          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8925         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8926         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8927         vv(1)=pizda(1,1)-pizda(2,2)
8928         vv(2)=pizda(1,2)+pizda(2,1)
8929         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8930          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8931          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8932 ! Cartesian gradient
8933         do iii=1,2
8934           do kkk=1,5
8935             do lll=1,3
8936               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8937                 pizda(1,1))
8938               vv(1)=pizda(1,1)-pizda(2,2)
8939               vv(2)=pizda(1,2)+pizda(2,1)
8940               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8941                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8942                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8943             enddo
8944           enddo
8945         enddo
8946 !d        goto 1112
8947 ! Contribution from graph IV
8948 !d1110    continue
8949         call transpose2(EE(1,1,itl),auxmat(1,1))
8950         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8951         vv(1)=pizda(1,1)+pizda(2,2)
8952         vv(2)=pizda(2,1)-pizda(1,2)
8953         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8954          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8955 ! Explicit gradient in virtual-dihedral angles.
8956         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8957          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8958         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8959         vv(1)=pizda(1,1)+pizda(2,2)
8960         vv(2)=pizda(2,1)-pizda(1,2)
8961         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8962          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8963          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8964 ! Cartesian gradient
8965         do iii=1,2
8966           do kkk=1,5
8967             do lll=1,3
8968               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8969                 pizda(1,1))
8970               vv(1)=pizda(1,1)+pizda(2,2)
8971               vv(2)=pizda(2,1)-pizda(1,2)
8972               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8973                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8974                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8975             enddo
8976           enddo
8977         enddo
8978       else
8979 ! Antiparallel orientation
8980 ! Contribution from graph III
8981 !        goto 1110
8982         call transpose2(EUg(1,1,j),auxmat(1,1))
8983         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8984         vv(1)=pizda(1,1)-pizda(2,2)
8985         vv(2)=pizda(1,2)+pizda(2,1)
8986         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8987          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8988 ! Explicit gradient in virtual-dihedral angles.
8989         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8990          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8991          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8992         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8993         vv(1)=pizda(1,1)-pizda(2,2)
8994         vv(2)=pizda(1,2)+pizda(2,1)
8995         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8996          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8997          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8998         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8999         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9000         vv(1)=pizda(1,1)-pizda(2,2)
9001         vv(2)=pizda(1,2)+pizda(2,1)
9002         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9003          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9004          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9005 ! Cartesian gradient
9006         do iii=1,2
9007           do kkk=1,5
9008             do lll=1,3
9009               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9010                 pizda(1,1))
9011               vv(1)=pizda(1,1)-pizda(2,2)
9012               vv(2)=pizda(1,2)+pizda(2,1)
9013               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9014                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9015                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9016             enddo
9017           enddo
9018         enddo
9019 !d        goto 1112
9020 ! Contribution from graph IV
9021 1110    continue
9022         call transpose2(EE(1,1,itj),auxmat(1,1))
9023         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9024         vv(1)=pizda(1,1)+pizda(2,2)
9025         vv(2)=pizda(2,1)-pizda(1,2)
9026         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9027          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9028 ! Explicit gradient in virtual-dihedral angles.
9029         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9030          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9031         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9032         vv(1)=pizda(1,1)+pizda(2,2)
9033         vv(2)=pizda(2,1)-pizda(1,2)
9034         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9035          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9036          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9037 ! Cartesian gradient
9038         do iii=1,2
9039           do kkk=1,5
9040             do lll=1,3
9041               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9042                 pizda(1,1))
9043               vv(1)=pizda(1,1)+pizda(2,2)
9044               vv(2)=pizda(2,1)-pizda(1,2)
9045               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9046                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9047                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9048             enddo
9049           enddo
9050         enddo
9051       endif
9052 1112  continue
9053       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9054 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9055 !d        write (2,*) 'ijkl',i,j,k,l
9056 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9057 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9058 !d      endif
9059 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9060 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9061 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9062 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9063       if (j.lt.nres-1) then
9064         j1=j+1
9065         j2=j-1
9066       else
9067         j1=j-1
9068         j2=j-2
9069       endif
9070       if (l.lt.nres-1) then
9071         l1=l+1
9072         l2=l-1
9073       else
9074         l1=l-1
9075         l2=l-2
9076       endif
9077 !d      eij=1.0d0
9078 !d      ekl=1.0d0
9079 !d      ekont=1.0d0
9080 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9081 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9082 !        summed up outside the subrouine as for the other subroutines
9083 !        handling long-range interactions. The old code is commented out
9084 !        with "cgrad" to keep track of changes.
9085       do ll=1,3
9086 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9087 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9088         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9089         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9090 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9091 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9092 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9093 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9094 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9095 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9096 !     &   gradcorr5ij,
9097 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9098 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9099 !grad        ghalf=0.5d0*ggg1(ll)
9100 !d        ghalf=0.0d0
9101         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9102         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9103         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9104         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9105         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9106         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9107 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9108 !grad        ghalf=0.5d0*ggg2(ll)
9109         ghalf=0.0d0
9110         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9111         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9112         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9113         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9114         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9115         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9116       enddo
9117 !d      goto 1112
9118 !grad      do m=i+1,j-1
9119 !grad        do ll=1,3
9120 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9121 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9122 !grad        enddo
9123 !grad      enddo
9124 !grad      do m=k+1,l-1
9125 !grad        do ll=1,3
9126 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9127 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9128 !grad        enddo
9129 !grad      enddo
9130 !1112  continue
9131 !grad      do m=i+2,j2
9132 !grad        do ll=1,3
9133 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9134 !grad        enddo
9135 !grad      enddo
9136 !grad      do m=k+2,l2
9137 !grad        do ll=1,3
9138 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9139 !grad        enddo
9140 !grad      enddo
9141 !d      do iii=1,nres-3
9142 !d        write (2,*) iii,g_corr5_loc(iii)
9143 !d      enddo
9144       eello5=ekont*eel5
9145 !d      write (2,*) 'ekont',ekont
9146 !d      write (iout,*) 'eello5',ekont*eel5
9147       return
9148       end function eello5
9149 !-----------------------------------------------------------------------------
9150       real(kind=8) function eello6(i,j,k,l,jj,kk)
9151 !      implicit real*8 (a-h,o-z)
9152 !      include 'DIMENSIONS'
9153 !      include 'COMMON.IOUNITS'
9154 !      include 'COMMON.CHAIN'
9155 !      include 'COMMON.DERIV'
9156 !      include 'COMMON.INTERACT'
9157 !      include 'COMMON.CONTACTS'
9158 !      include 'COMMON.TORSION'
9159 !      include 'COMMON.VAR'
9160 !      include 'COMMON.GEO'
9161 !      include 'COMMON.FFIELD'
9162       real(kind=8),dimension(3) :: ggg1,ggg2
9163       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9164                    eello6_6,eel6
9165       real(kind=8) :: gradcorr6ij,gradcorr6kl
9166       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9167 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9168 !d        eello6=0.0d0
9169 !d        return
9170 !d      endif
9171 !d      write (iout,*)
9172 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9173 !d     &   ' and',k,l
9174       eello6_1=0.0d0
9175       eello6_2=0.0d0
9176       eello6_3=0.0d0
9177       eello6_4=0.0d0
9178       eello6_5=0.0d0
9179       eello6_6=0.0d0
9180 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9181 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9182       do iii=1,2
9183         do kkk=1,5
9184           do lll=1,3
9185             derx(lll,kkk,iii)=0.0d0
9186           enddo
9187         enddo
9188       enddo
9189 !d      eij=facont_hb(jj,i)
9190 !d      ekl=facont_hb(kk,k)
9191 !d      ekont=eij*ekl
9192 !d      eij=1.0d0
9193 !d      ekl=1.0d0
9194 !d      ekont=1.0d0
9195       if (l.eq.j+1) then
9196         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9197         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9198         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9199         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9200         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9201         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9202       else
9203         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9204         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9205         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9206         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9207         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9208           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9209         else
9210           eello6_5=0.0d0
9211         endif
9212         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9213       endif
9214 ! If turn contributions are considered, they will be handled separately.
9215       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9216 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9217 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9218 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9219 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9220 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9221 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9222 !d      goto 1112
9223       if (j.lt.nres-1) then
9224         j1=j+1
9225         j2=j-1
9226       else
9227         j1=j-1
9228         j2=j-2
9229       endif
9230       if (l.lt.nres-1) then
9231         l1=l+1
9232         l2=l-1
9233       else
9234         l1=l-1
9235         l2=l-2
9236       endif
9237       do ll=1,3
9238 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9239 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9240 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9241 !grad        ghalf=0.5d0*ggg1(ll)
9242 !d        ghalf=0.0d0
9243         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9244         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9245         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9246         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9247         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9248         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9249         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9250         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9251 !grad        ghalf=0.5d0*ggg2(ll)
9252 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9253 !d        ghalf=0.0d0
9254         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9255         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9256         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9257         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9258         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9259         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9260       enddo
9261 !d      goto 1112
9262 !grad      do m=i+1,j-1
9263 !grad        do ll=1,3
9264 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9265 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9266 !grad        enddo
9267 !grad      enddo
9268 !grad      do m=k+1,l-1
9269 !grad        do ll=1,3
9270 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9271 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9272 !grad        enddo
9273 !grad      enddo
9274 !grad1112  continue
9275 !grad      do m=i+2,j2
9276 !grad        do ll=1,3
9277 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9278 !grad        enddo
9279 !grad      enddo
9280 !grad      do m=k+2,l2
9281 !grad        do ll=1,3
9282 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9283 !grad        enddo
9284 !grad      enddo
9285 !d      do iii=1,nres-3
9286 !d        write (2,*) iii,g_corr6_loc(iii)
9287 !d      enddo
9288       eello6=ekont*eel6
9289 !d      write (2,*) 'ekont',ekont
9290 !d      write (iout,*) 'eello6',ekont*eel6
9291       return
9292       end function eello6
9293 !-----------------------------------------------------------------------------
9294       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9295       use comm_kut
9296 !      implicit real*8 (a-h,o-z)
9297 !      include 'DIMENSIONS'
9298 !      include 'COMMON.IOUNITS'
9299 !      include 'COMMON.CHAIN'
9300 !      include 'COMMON.DERIV'
9301 !      include 'COMMON.INTERACT'
9302 !      include 'COMMON.CONTACTS'
9303 !      include 'COMMON.TORSION'
9304 !      include 'COMMON.VAR'
9305 !      include 'COMMON.GEO'
9306       real(kind=8),dimension(2) :: vv,vv1
9307       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9308       logical :: swap
9309 !el      logical :: lprn
9310 !el      common /kutas/ lprn
9311       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9312       real(kind=8) :: s1,s2,s3,s4,s5
9313 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9314 !                                                                              C
9315 !      Parallel       Antiparallel                                             C
9316 !                                                                              C
9317 !          o             o                                                     C
9318 !         /l\           /j\                                                    C
9319 !        /   \         /   \                                                   C
9320 !       /| o |         | o |\                                                  C
9321 !     \ j|/k\|  /   \  |/k\|l /                                                C
9322 !      \ /   \ /     \ /   \ /                                                 C
9323 !       o     o       o     o                                                  C
9324 !       i             i                                                        C
9325 !                                                                              C
9326 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9327       itk=itortyp(itype(k,1))
9328       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9329       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9330       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9331       call transpose2(EUgC(1,1,k),auxmat(1,1))
9332       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9333       vv1(1)=pizda1(1,1)-pizda1(2,2)
9334       vv1(2)=pizda1(1,2)+pizda1(2,1)
9335       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9336       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9337       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9338       s5=scalar2(vv(1),Dtobr2(1,i))
9339 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9340       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9341       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9342        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9343        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9344        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9345        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9346        +scalar2(vv(1),Dtobr2der(1,i)))
9347       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9348       vv1(1)=pizda1(1,1)-pizda1(2,2)
9349       vv1(2)=pizda1(1,2)+pizda1(2,1)
9350       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9351       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9352       if (l.eq.j+1) then
9353         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9354        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9355        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9356        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9357        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9358       else
9359         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9360        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9361        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9362        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9363        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9364       endif
9365       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9366       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9367       vv1(1)=pizda1(1,1)-pizda1(2,2)
9368       vv1(2)=pizda1(1,2)+pizda1(2,1)
9369       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9370        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9371        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9372        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9373       do iii=1,2
9374         if (swap) then
9375           ind=3-iii
9376         else
9377           ind=iii
9378         endif
9379         do kkk=1,5
9380           do lll=1,3
9381             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9382             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9383             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9384             call transpose2(EUgC(1,1,k),auxmat(1,1))
9385             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9386               pizda1(1,1))
9387             vv1(1)=pizda1(1,1)-pizda1(2,2)
9388             vv1(2)=pizda1(1,2)+pizda1(2,1)
9389             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9390             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9391              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9392             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9393              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9394             s5=scalar2(vv(1),Dtobr2(1,i))
9395             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9396           enddo
9397         enddo
9398       enddo
9399       return
9400       end function eello6_graph1
9401 !-----------------------------------------------------------------------------
9402       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9403       use comm_kut
9404 !      implicit real*8 (a-h,o-z)
9405 !      include 'DIMENSIONS'
9406 !      include 'COMMON.IOUNITS'
9407 !      include 'COMMON.CHAIN'
9408 !      include 'COMMON.DERIV'
9409 !      include 'COMMON.INTERACT'
9410 !      include 'COMMON.CONTACTS'
9411 !      include 'COMMON.TORSION'
9412 !      include 'COMMON.VAR'
9413 !      include 'COMMON.GEO'
9414       logical :: swap
9415       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9416       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9417 !el      logical :: lprn
9418 !el      common /kutas/ lprn
9419       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9420       real(kind=8) :: s2,s3,s4
9421 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9422 !                                                                              C
9423 !      Parallel       Antiparallel                                             C
9424 !                                                                              C
9425 !          o             o                                                     C
9426 !     \   /l\           /j\   /                                                C
9427 !      \ /   \         /   \ /                                                 C
9428 !       o| o |         | o |o                                                  C
9429 !     \ j|/k\|      \  |/k\|l                                                  C
9430 !      \ /   \       \ /   \                                                   C
9431 !       o             o                                                        C
9432 !       i             i                                                        C
9433 !                                                                              C
9434 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9435 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9436 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9437 !           but not in a cluster cumulant
9438 #ifdef MOMENT
9439       s1=dip(1,jj,i)*dip(1,kk,k)
9440 #endif
9441       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9442       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9443       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9444       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9445       call transpose2(EUg(1,1,k),auxmat(1,1))
9446       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9447       vv(1)=pizda(1,1)-pizda(2,2)
9448       vv(2)=pizda(1,2)+pizda(2,1)
9449       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9450 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9451 #ifdef MOMENT
9452       eello6_graph2=-(s1+s2+s3+s4)
9453 #else
9454       eello6_graph2=-(s2+s3+s4)
9455 #endif
9456 !      eello6_graph2=-s3
9457 ! Derivatives in gamma(i-1)
9458       if (i.gt.1) then
9459 #ifdef MOMENT
9460         s1=dipderg(1,jj,i)*dip(1,kk,k)
9461 #endif
9462         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9463         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9464         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9465         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9466 #ifdef MOMENT
9467         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9468 #else
9469         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9470 #endif
9471 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9472       endif
9473 ! Derivatives in gamma(k-1)
9474 #ifdef MOMENT
9475       s1=dip(1,jj,i)*dipderg(1,kk,k)
9476 #endif
9477       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9478       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9479       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9480       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9481       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9482       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9483       vv(1)=pizda(1,1)-pizda(2,2)
9484       vv(2)=pizda(1,2)+pizda(2,1)
9485       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9486 #ifdef MOMENT
9487       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9488 #else
9489       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9490 #endif
9491 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9492 ! Derivatives in gamma(j-1) or gamma(l-1)
9493       if (j.gt.1) then
9494 #ifdef MOMENT
9495         s1=dipderg(3,jj,i)*dip(1,kk,k)
9496 #endif
9497         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9498         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9499         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9500         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9501         vv(1)=pizda(1,1)-pizda(2,2)
9502         vv(2)=pizda(1,2)+pizda(2,1)
9503         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9504 #ifdef MOMENT
9505         if (swap) then
9506           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9507         else
9508           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9509         endif
9510 #endif
9511         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9512 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9513       endif
9514 ! Derivatives in gamma(l-1) or gamma(j-1)
9515       if (l.gt.1) then
9516 #ifdef MOMENT
9517         s1=dip(1,jj,i)*dipderg(3,kk,k)
9518 #endif
9519         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9520         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9521         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9522         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9523         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9524         vv(1)=pizda(1,1)-pizda(2,2)
9525         vv(2)=pizda(1,2)+pizda(2,1)
9526         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9527 #ifdef MOMENT
9528         if (swap) then
9529           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9530         else
9531           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9532         endif
9533 #endif
9534         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9535 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9536       endif
9537 ! Cartesian derivatives.
9538       if (lprn) then
9539         write (2,*) 'In eello6_graph2'
9540         do iii=1,2
9541           write (2,*) 'iii=',iii
9542           do kkk=1,5
9543             write (2,*) 'kkk=',kkk
9544             do jjj=1,2
9545               write (2,'(3(2f10.5),5x)') &
9546               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9547             enddo
9548           enddo
9549         enddo
9550       endif
9551       do iii=1,2
9552         do kkk=1,5
9553           do lll=1,3
9554 #ifdef MOMENT
9555             if (iii.eq.1) then
9556               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9557             else
9558               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9559             endif
9560 #endif
9561             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9562               auxvec(1))
9563             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9564             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9565               auxvec(1))
9566             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9567             call transpose2(EUg(1,1,k),auxmat(1,1))
9568             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9569               pizda(1,1))
9570             vv(1)=pizda(1,1)-pizda(2,2)
9571             vv(2)=pizda(1,2)+pizda(2,1)
9572             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9573 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9574 #ifdef MOMENT
9575             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9576 #else
9577             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9578 #endif
9579             if (swap) then
9580               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9581             else
9582               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9583             endif
9584           enddo
9585         enddo
9586       enddo
9587       return
9588       end function eello6_graph2
9589 !-----------------------------------------------------------------------------
9590       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9591 !      implicit real*8 (a-h,o-z)
9592 !      include 'DIMENSIONS'
9593 !      include 'COMMON.IOUNITS'
9594 !      include 'COMMON.CHAIN'
9595 !      include 'COMMON.DERIV'
9596 !      include 'COMMON.INTERACT'
9597 !      include 'COMMON.CONTACTS'
9598 !      include 'COMMON.TORSION'
9599 !      include 'COMMON.VAR'
9600 !      include 'COMMON.GEO'
9601       real(kind=8),dimension(2) :: vv,auxvec
9602       real(kind=8),dimension(2,2) :: pizda,auxmat
9603       logical :: swap
9604       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9605       real(kind=8) :: s1,s2,s3,s4
9606 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9607 !                                                                              C
9608 !      Parallel       Antiparallel                                             C
9609 !                                                                              C
9610 !          o             o                                                     C
9611 !         /l\   /   \   /j\                                                    C
9612 !        /   \ /     \ /   \                                                   C
9613 !       /| o |o       o| o |\                                                  C
9614 !       j|/k\|  /      |/k\|l /                                                C
9615 !        /   \ /       /   \ /                                                 C
9616 !       /     o       /     o                                                  C
9617 !       i             i                                                        C
9618 !                                                                              C
9619 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9620 !
9621 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9622 !           energy moment and not to the cluster cumulant.
9623       iti=itortyp(itype(i,1))
9624       if (j.lt.nres-1) then
9625         itj1=itortyp(itype(j+1,1))
9626       else
9627         itj1=ntortyp+1
9628       endif
9629       itk=itortyp(itype(k,1))
9630       itk1=itortyp(itype(k+1,1))
9631       if (l.lt.nres-1) then
9632         itl1=itortyp(itype(l+1,1))
9633       else
9634         itl1=ntortyp+1
9635       endif
9636 #ifdef MOMENT
9637       s1=dip(4,jj,i)*dip(4,kk,k)
9638 #endif
9639       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9640       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9641       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9642       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9643       call transpose2(EE(1,1,itk),auxmat(1,1))
9644       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9645       vv(1)=pizda(1,1)+pizda(2,2)
9646       vv(2)=pizda(2,1)-pizda(1,2)
9647       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9648 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9649 !d     & "sum",-(s2+s3+s4)
9650 #ifdef MOMENT
9651       eello6_graph3=-(s1+s2+s3+s4)
9652 #else
9653       eello6_graph3=-(s2+s3+s4)
9654 #endif
9655 !      eello6_graph3=-s4
9656 ! Derivatives in gamma(k-1)
9657       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9658       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9659       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9660       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9661 ! Derivatives in gamma(l-1)
9662       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9663       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9664       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9665       vv(1)=pizda(1,1)+pizda(2,2)
9666       vv(2)=pizda(2,1)-pizda(1,2)
9667       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9668       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9669 ! Cartesian derivatives.
9670       do iii=1,2
9671         do kkk=1,5
9672           do lll=1,3
9673 #ifdef MOMENT
9674             if (iii.eq.1) then
9675               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9676             else
9677               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9678             endif
9679 #endif
9680             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9681               auxvec(1))
9682             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9683             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9684               auxvec(1))
9685             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9686             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9687               pizda(1,1))
9688             vv(1)=pizda(1,1)+pizda(2,2)
9689             vv(2)=pizda(2,1)-pizda(1,2)
9690             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9691 #ifdef MOMENT
9692             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9693 #else
9694             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9695 #endif
9696             if (swap) then
9697               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9698             else
9699               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9700             endif
9701 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9702           enddo
9703         enddo
9704       enddo
9705       return
9706       end function eello6_graph3
9707 !-----------------------------------------------------------------------------
9708       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9709 !      implicit real*8 (a-h,o-z)
9710 !      include 'DIMENSIONS'
9711 !      include 'COMMON.IOUNITS'
9712 !      include 'COMMON.CHAIN'
9713 !      include 'COMMON.DERIV'
9714 !      include 'COMMON.INTERACT'
9715 !      include 'COMMON.CONTACTS'
9716 !      include 'COMMON.TORSION'
9717 !      include 'COMMON.VAR'
9718 !      include 'COMMON.GEO'
9719 !      include 'COMMON.FFIELD'
9720       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9721       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9722       logical :: swap
9723       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9724               iii,kkk,lll
9725       real(kind=8) :: s1,s2,s3,s4
9726 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9727 !                                                                              C
9728 !      Parallel       Antiparallel                                             C
9729 !                                                                              C
9730 !          o             o                                                     C
9731 !         /l\   /   \   /j\                                                    C
9732 !        /   \ /     \ /   \                                                   C
9733 !       /| o |o       o| o |\                                                  C
9734 !     \ j|/k\|      \  |/k\|l                                                  C
9735 !      \ /   \       \ /   \                                                   C
9736 !       o     \       o     \                                                  C
9737 !       i             i                                                        C
9738 !                                                                              C
9739 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9740 !
9741 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9742 !           energy moment and not to the cluster cumulant.
9743 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9744       iti=itortyp(itype(i,1))
9745       itj=itortyp(itype(j,1))
9746       if (j.lt.nres-1) then
9747         itj1=itortyp(itype(j+1,1))
9748       else
9749         itj1=ntortyp+1
9750       endif
9751       itk=itortyp(itype(k,1))
9752       if (k.lt.nres-1) then
9753         itk1=itortyp(itype(k+1,1))
9754       else
9755         itk1=ntortyp+1
9756       endif
9757       itl=itortyp(itype(l,1))
9758       if (l.lt.nres-1) then
9759         itl1=itortyp(itype(l+1,1))
9760       else
9761         itl1=ntortyp+1
9762       endif
9763 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9764 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9765 !d     & ' itl',itl,' itl1',itl1
9766 #ifdef MOMENT
9767       if (imat.eq.1) then
9768         s1=dip(3,jj,i)*dip(3,kk,k)
9769       else
9770         s1=dip(2,jj,j)*dip(2,kk,l)
9771       endif
9772 #endif
9773       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9774       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9775       if (j.eq.l+1) then
9776         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9777         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9778       else
9779         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9780         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9781       endif
9782       call transpose2(EUg(1,1,k),auxmat(1,1))
9783       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9784       vv(1)=pizda(1,1)-pizda(2,2)
9785       vv(2)=pizda(2,1)+pizda(1,2)
9786       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9787 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9788 #ifdef MOMENT
9789       eello6_graph4=-(s1+s2+s3+s4)
9790 #else
9791       eello6_graph4=-(s2+s3+s4)
9792 #endif
9793 ! Derivatives in gamma(i-1)
9794       if (i.gt.1) then
9795 #ifdef MOMENT
9796         if (imat.eq.1) then
9797           s1=dipderg(2,jj,i)*dip(3,kk,k)
9798         else
9799           s1=dipderg(4,jj,j)*dip(2,kk,l)
9800         endif
9801 #endif
9802         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9803         if (j.eq.l+1) then
9804           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9805           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9806         else
9807           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9808           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9809         endif
9810         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9811         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9812 !d          write (2,*) 'turn6 derivatives'
9813 #ifdef MOMENT
9814           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9815 #else
9816           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9817 #endif
9818         else
9819 #ifdef MOMENT
9820           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9821 #else
9822           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9823 #endif
9824         endif
9825       endif
9826 ! Derivatives in gamma(k-1)
9827 #ifdef MOMENT
9828       if (imat.eq.1) then
9829         s1=dip(3,jj,i)*dipderg(2,kk,k)
9830       else
9831         s1=dip(2,jj,j)*dipderg(4,kk,l)
9832       endif
9833 #endif
9834       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9835       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9836       if (j.eq.l+1) then
9837         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9838         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9839       else
9840         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9841         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9842       endif
9843       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9844       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9845       vv(1)=pizda(1,1)-pizda(2,2)
9846       vv(2)=pizda(2,1)+pizda(1,2)
9847       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9848       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9849 #ifdef MOMENT
9850         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9851 #else
9852         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9853 #endif
9854       else
9855 #ifdef MOMENT
9856         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9857 #else
9858         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9859 #endif
9860       endif
9861 ! Derivatives in gamma(j-1) or gamma(l-1)
9862       if (l.eq.j+1 .and. l.gt.1) then
9863         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9864         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9865         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9866         vv(1)=pizda(1,1)-pizda(2,2)
9867         vv(2)=pizda(2,1)+pizda(1,2)
9868         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9869         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9870       else if (j.gt.1) then
9871         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9872         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9873         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9874         vv(1)=pizda(1,1)-pizda(2,2)
9875         vv(2)=pizda(2,1)+pizda(1,2)
9876         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9877         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9878           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9879         else
9880           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9881         endif
9882       endif
9883 ! Cartesian derivatives.
9884       do iii=1,2
9885         do kkk=1,5
9886           do lll=1,3
9887 #ifdef MOMENT
9888             if (iii.eq.1) then
9889               if (imat.eq.1) then
9890                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9891               else
9892                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9893               endif
9894             else
9895               if (imat.eq.1) then
9896                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9897               else
9898                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9899               endif
9900             endif
9901 #endif
9902             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9903               auxvec(1))
9904             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9905             if (j.eq.l+1) then
9906               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9907                 b1(1,itj1),auxvec(1))
9908               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9909             else
9910               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9911                 b1(1,itl1),auxvec(1))
9912               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9913             endif
9914             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9915               pizda(1,1))
9916             vv(1)=pizda(1,1)-pizda(2,2)
9917             vv(2)=pizda(2,1)+pizda(1,2)
9918             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9919             if (swap) then
9920               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9921 #ifdef MOMENT
9922                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9923                    -(s1+s2+s4)
9924 #else
9925                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9926                    -(s2+s4)
9927 #endif
9928                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9929               else
9930 #ifdef MOMENT
9931                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9932 #else
9933                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9934 #endif
9935                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9936               endif
9937             else
9938 #ifdef MOMENT
9939               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9940 #else
9941               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9942 #endif
9943               if (l.eq.j+1) then
9944                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9945               else
9946                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9947               endif
9948             endif
9949           enddo
9950         enddo
9951       enddo
9952       return
9953       end function eello6_graph4
9954 !-----------------------------------------------------------------------------
9955       real(kind=8) function eello_turn6(i,jj,kk)
9956 !      implicit real*8 (a-h,o-z)
9957 !      include 'DIMENSIONS'
9958 !      include 'COMMON.IOUNITS'
9959 !      include 'COMMON.CHAIN'
9960 !      include 'COMMON.DERIV'
9961 !      include 'COMMON.INTERACT'
9962 !      include 'COMMON.CONTACTS'
9963 !      include 'COMMON.TORSION'
9964 !      include 'COMMON.VAR'
9965 !      include 'COMMON.GEO'
9966       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9967       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9968       real(kind=8),dimension(3) :: ggg1,ggg2
9969       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9970       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9971 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9972 !           the respective energy moment and not to the cluster cumulant.
9973 !el local variables
9974       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9975       integer :: j1,j2,l1,l2,ll
9976       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9977       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9978       s1=0.0d0
9979       s8=0.0d0
9980       s13=0.0d0
9981 !
9982       eello_turn6=0.0d0
9983       j=i+4
9984       k=i+1
9985       l=i+3
9986       iti=itortyp(itype(i,1))
9987       itk=itortyp(itype(k,1))
9988       itk1=itortyp(itype(k+1,1))
9989       itl=itortyp(itype(l,1))
9990       itj=itortyp(itype(j,1))
9991 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9992 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9993 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9994 !d        eello6=0.0d0
9995 !d        return
9996 !d      endif
9997 !d      write (iout,*)
9998 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9999 !d     &   ' and',k,l
10000 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10001       do iii=1,2
10002         do kkk=1,5
10003           do lll=1,3
10004             derx_turn(lll,kkk,iii)=0.0d0
10005           enddo
10006         enddo
10007       enddo
10008 !d      eij=1.0d0
10009 !d      ekl=1.0d0
10010 !d      ekont=1.0d0
10011       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10012 !d      eello6_5=0.0d0
10013 !d      write (2,*) 'eello6_5',eello6_5
10014 #ifdef MOMENT
10015       call transpose2(AEA(1,1,1),auxmat(1,1))
10016       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10017       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10018       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10019 #endif
10020       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10021       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10022       s2 = scalar2(b1(1,itk),vtemp1(1))
10023 #ifdef MOMENT
10024       call transpose2(AEA(1,1,2),atemp(1,1))
10025       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10026       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10027       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10028 #endif
10029       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10030       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10031       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10032 #ifdef MOMENT
10033       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10034       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10035       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10036       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10037       ss13 = scalar2(b1(1,itk),vtemp4(1))
10038       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10039 #endif
10040 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10041 !      s1=0.0d0
10042 !      s2=0.0d0
10043 !      s8=0.0d0
10044 !      s12=0.0d0
10045 !      s13=0.0d0
10046       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10047 ! Derivatives in gamma(i+2)
10048       s1d =0.0d0
10049       s8d =0.0d0
10050 #ifdef MOMENT
10051       call transpose2(AEA(1,1,1),auxmatd(1,1))
10052       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10053       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10054       call transpose2(AEAderg(1,1,2),atempd(1,1))
10055       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10056       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10057 #endif
10058       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10059       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10060       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10061 !      s1d=0.0d0
10062 !      s2d=0.0d0
10063 !      s8d=0.0d0
10064 !      s12d=0.0d0
10065 !      s13d=0.0d0
10066       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10067 ! Derivatives in gamma(i+3)
10068 #ifdef MOMENT
10069       call transpose2(AEA(1,1,1),auxmatd(1,1))
10070       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10071       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10072       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10073 #endif
10074       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10075       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10076       s2d = scalar2(b1(1,itk),vtemp1d(1))
10077 #ifdef MOMENT
10078       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10079       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10080 #endif
10081       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10082 #ifdef MOMENT
10083       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10084       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10085       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10086 #endif
10087 !      s1d=0.0d0
10088 !      s2d=0.0d0
10089 !      s8d=0.0d0
10090 !      s12d=0.0d0
10091 !      s13d=0.0d0
10092 #ifdef MOMENT
10093       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10094                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10095 #else
10096       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10097                     -0.5d0*ekont*(s2d+s12d)
10098 #endif
10099 ! Derivatives in gamma(i+4)
10100       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10101       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10102       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10103 #ifdef MOMENT
10104       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10105       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10106       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10107 #endif
10108 !      s1d=0.0d0
10109 !      s2d=0.0d0
10110 !      s8d=0.0d0
10111 !      s12d=0.0d0
10112 !      s13d=0.0d0
10113 #ifdef MOMENT
10114       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10115 #else
10116       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10117 #endif
10118 ! Derivatives in gamma(i+5)
10119 #ifdef MOMENT
10120       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10121       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10122       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10123 #endif
10124       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10125       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10126       s2d = scalar2(b1(1,itk),vtemp1d(1))
10127 #ifdef MOMENT
10128       call transpose2(AEA(1,1,2),atempd(1,1))
10129       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10130       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10131 #endif
10132       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10133       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10134 #ifdef MOMENT
10135       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10136       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10137       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10138 #endif
10139 !      s1d=0.0d0
10140 !      s2d=0.0d0
10141 !      s8d=0.0d0
10142 !      s12d=0.0d0
10143 !      s13d=0.0d0
10144 #ifdef MOMENT
10145       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10146                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10147 #else
10148       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10149                     -0.5d0*ekont*(s2d+s12d)
10150 #endif
10151 ! Cartesian derivatives
10152       do iii=1,2
10153         do kkk=1,5
10154           do lll=1,3
10155 #ifdef MOMENT
10156             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10157             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10158             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10159 #endif
10160             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10161             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10162                 vtemp1d(1))
10163             s2d = scalar2(b1(1,itk),vtemp1d(1))
10164 #ifdef MOMENT
10165             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10166             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10167             s8d = -(atempd(1,1)+atempd(2,2))* &
10168                  scalar2(cc(1,1,itl),vtemp2(1))
10169 #endif
10170             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10171                  auxmatd(1,1))
10172             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10173             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10174 !      s1d=0.0d0
10175 !      s2d=0.0d0
10176 !      s8d=0.0d0
10177 !      s12d=0.0d0
10178 !      s13d=0.0d0
10179 #ifdef MOMENT
10180             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10181               - 0.5d0*(s1d+s2d)
10182 #else
10183             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10184               - 0.5d0*s2d
10185 #endif
10186 #ifdef MOMENT
10187             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10188               - 0.5d0*(s8d+s12d)
10189 #else
10190             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10191               - 0.5d0*s12d
10192 #endif
10193           enddo
10194         enddo
10195       enddo
10196 #ifdef MOMENT
10197       do kkk=1,5
10198         do lll=1,3
10199           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10200             achuj_tempd(1,1))
10201           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10202           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10203           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10204           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10205           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10206             vtemp4d(1))
10207           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10208           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10209           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10210         enddo
10211       enddo
10212 #endif
10213 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10214 !d     &  16*eel_turn6_num
10215 !d      goto 1112
10216       if (j.lt.nres-1) then
10217         j1=j+1
10218         j2=j-1
10219       else
10220         j1=j-1
10221         j2=j-2
10222       endif
10223       if (l.lt.nres-1) then
10224         l1=l+1
10225         l2=l-1
10226       else
10227         l1=l-1
10228         l2=l-2
10229       endif
10230       do ll=1,3
10231 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10232 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10233 !grad        ghalf=0.5d0*ggg1(ll)
10234 !d        ghalf=0.0d0
10235         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10236         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10237         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10238           +ekont*derx_turn(ll,2,1)
10239         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10240         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10241           +ekont*derx_turn(ll,4,1)
10242         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10243         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10244         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10245 !grad        ghalf=0.5d0*ggg2(ll)
10246 !d        ghalf=0.0d0
10247         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10248           +ekont*derx_turn(ll,2,2)
10249         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10250         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10251           +ekont*derx_turn(ll,4,2)
10252         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10253         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10254         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10255       enddo
10256 !d      goto 1112
10257 !grad      do m=i+1,j-1
10258 !grad        do ll=1,3
10259 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10260 !grad        enddo
10261 !grad      enddo
10262 !grad      do m=k+1,l-1
10263 !grad        do ll=1,3
10264 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10265 !grad        enddo
10266 !grad      enddo
10267 !grad1112  continue
10268 !grad      do m=i+2,j2
10269 !grad        do ll=1,3
10270 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10271 !grad        enddo
10272 !grad      enddo
10273 !grad      do m=k+2,l2
10274 !grad        do ll=1,3
10275 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10276 !grad        enddo
10277 !grad      enddo
10278 !d      do iii=1,nres-3
10279 !d        write (2,*) iii,g_corr6_loc(iii)
10280 !d      enddo
10281       eello_turn6=ekont*eel_turn6
10282 !d      write (2,*) 'ekont',ekont
10283 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10284       return
10285       end function eello_turn6
10286 !-----------------------------------------------------------------------------
10287       subroutine MATVEC2(A1,V1,V2)
10288 !DIR$ INLINEALWAYS MATVEC2
10289 #ifndef OSF
10290 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10291 #endif
10292 !      implicit real*8 (a-h,o-z)
10293 !      include 'DIMENSIONS'
10294       real(kind=8),dimension(2) :: V1,V2
10295       real(kind=8),dimension(2,2) :: A1
10296       real(kind=8) :: vaux1,vaux2
10297 !      DO 1 I=1,2
10298 !        VI=0.0
10299 !        DO 3 K=1,2
10300 !    3     VI=VI+A1(I,K)*V1(K)
10301 !        Vaux(I)=VI
10302 !    1 CONTINUE
10303
10304       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10305       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10306
10307       v2(1)=vaux1
10308       v2(2)=vaux2
10309       end subroutine MATVEC2
10310 !-----------------------------------------------------------------------------
10311       subroutine MATMAT2(A1,A2,A3)
10312 #ifndef OSF
10313 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10314 #endif
10315 !      implicit real*8 (a-h,o-z)
10316 !      include 'DIMENSIONS'
10317       real(kind=8),dimension(2,2) :: A1,A2,A3
10318       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10319 !      DIMENSION AI3(2,2)
10320 !        DO  J=1,2
10321 !          A3IJ=0.0
10322 !          DO K=1,2
10323 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10324 !          enddo
10325 !          A3(I,J)=A3IJ
10326 !       enddo
10327 !      enddo
10328
10329       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10330       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10331       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10332       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10333
10334       A3(1,1)=AI3_11
10335       A3(2,1)=AI3_21
10336       A3(1,2)=AI3_12
10337       A3(2,2)=AI3_22
10338       end subroutine MATMAT2
10339 !-----------------------------------------------------------------------------
10340       real(kind=8) function scalar2(u,v)
10341 !DIR$ INLINEALWAYS scalar2
10342       implicit none
10343       real(kind=8),dimension(2) :: u,v
10344       real(kind=8) :: sc
10345       integer :: i
10346       scalar2=u(1)*v(1)+u(2)*v(2)
10347       return
10348       end function scalar2
10349 !-----------------------------------------------------------------------------
10350       subroutine transpose2(a,at)
10351 !DIR$ INLINEALWAYS transpose2
10352 #ifndef OSF
10353 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10354 #endif
10355       implicit none
10356       real(kind=8),dimension(2,2) :: a,at
10357       at(1,1)=a(1,1)
10358       at(1,2)=a(2,1)
10359       at(2,1)=a(1,2)
10360       at(2,2)=a(2,2)
10361       return
10362       end subroutine transpose2
10363 !-----------------------------------------------------------------------------
10364       subroutine transpose(n,a,at)
10365       implicit none
10366       integer :: n,i,j
10367       real(kind=8),dimension(n,n) :: a,at
10368       do i=1,n
10369         do j=1,n
10370           at(j,i)=a(i,j)
10371         enddo
10372       enddo
10373       return
10374       end subroutine transpose
10375 !-----------------------------------------------------------------------------
10376       subroutine prodmat3(a1,a2,kk,transp,prod)
10377 !DIR$ INLINEALWAYS prodmat3
10378 #ifndef OSF
10379 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10380 #endif
10381       implicit none
10382       integer :: i,j
10383       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10384       logical :: transp
10385 !rc      double precision auxmat(2,2),prod_(2,2)
10386
10387       if (transp) then
10388 !rc        call transpose2(kk(1,1),auxmat(1,1))
10389 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10390 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10391
10392            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10393        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10394            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10395        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10396            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10397        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10398            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10399        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10400
10401       else
10402 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10403 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10404
10405            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10406         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10407            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10408         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10409            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10410         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10411            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10412         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10413
10414       endif
10415 !      call transpose2(a2(1,1),a2t(1,1))
10416
10417 !rc      print *,transp
10418 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10419 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10420
10421       return
10422       end subroutine prodmat3
10423 !-----------------------------------------------------------------------------
10424 ! energy_p_new_barrier.F
10425 !-----------------------------------------------------------------------------
10426       subroutine sum_gradient
10427 !      implicit real*8 (a-h,o-z)
10428       use io_base, only: pdbout
10429 !      include 'DIMENSIONS'
10430 #ifndef ISNAN
10431       external proc_proc
10432 #ifdef WINPGI
10433 !MS$ATTRIBUTES C ::  proc_proc
10434 #endif
10435 #endif
10436 #ifdef MPI
10437       include 'mpif.h'
10438 #endif
10439       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10440                    gloc_scbuf !(3,maxres)
10441
10442       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10443 !#endif
10444 !el local variables
10445       integer :: i,j,k,ierror,ierr
10446       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10447                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10448                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10449                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10450                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10451                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10452                    gsccorr_max,gsccorrx_max,time00
10453
10454 !      include 'COMMON.SETUP'
10455 !      include 'COMMON.IOUNITS'
10456 !      include 'COMMON.FFIELD'
10457 !      include 'COMMON.DERIV'
10458 !      include 'COMMON.INTERACT'
10459 !      include 'COMMON.SBRIDGE'
10460 !      include 'COMMON.CHAIN'
10461 !      include 'COMMON.VAR'
10462 !      include 'COMMON.CONTROL'
10463 !      include 'COMMON.TIME1'
10464 !      include 'COMMON.MAXGRAD'
10465 !      include 'COMMON.SCCOR'
10466 #ifdef TIMING
10467       time01=MPI_Wtime()
10468 #endif
10469 #ifdef DEBUG
10470       write (iout,*) "sum_gradient gvdwc, gvdwx"
10471       do i=1,nres
10472         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10473          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10474       enddo
10475       call flush(iout)
10476 #endif
10477 #ifdef MPI
10478         gradbufc=0.0d0
10479         gradbufx=0.0d0
10480         gradbufc_sum=0.0d0
10481         gloc_scbuf=0.0d0
10482         glocbuf=0.0d0
10483 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10484         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10485           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10486 #endif
10487 !
10488 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10489 !            in virtual-bond-vector coordinates
10490 !
10491 #ifdef DEBUG
10492 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10493 !      do i=1,nres-1
10494 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10495 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10496 !      enddo
10497 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10498 !      do i=1,nres-1
10499 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10500 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10501 !      enddo
10502       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10503       do i=1,nres
10504         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10505          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10506          (gvdwc_scpp(j,i),j=1,3)
10507       enddo
10508       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10509       do i=1,nres
10510         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10511          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10512          (gelc_loc_long(j,i),j=1,3)
10513       enddo
10514       call flush(iout)
10515 #endif
10516 #ifdef SPLITELE
10517       do i=0,nct
10518         do j=1,3
10519           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10520                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10521                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10522                       wel_loc*gel_loc_long(j,i)+ &
10523                       wcorr*gradcorr_long(j,i)+ &
10524                       wcorr5*gradcorr5_long(j,i)+ &
10525                       wcorr6*gradcorr6_long(j,i)+ &
10526                       wturn6*gcorr6_turn_long(j,i)+ &
10527                       wstrain*ghpbc(j,i) &
10528                      +wliptran*gliptranc(j,i) &
10529                      +gradafm(j,i) &
10530                      +welec*gshieldc(j,i) &
10531                      +wcorr*gshieldc_ec(j,i) &
10532                      +wturn3*gshieldc_t3(j,i)&
10533                      +wturn4*gshieldc_t4(j,i)&
10534                      +wel_loc*gshieldc_ll(j,i)&
10535                      +wtube*gg_tube(j,i) &
10536                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10537                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10538                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10539                      wcorr_nucl*gradcorr_nucl(j,i)&
10540                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10541                      wcatprot* gradpepcat(j,i)+ &
10542                      wcatcat*gradcatcat(j,i)+   &
10543                      wscbase*gvdwc_scbase(j,i)+ &
10544                      wpepbase*gvdwc_pepbase(j,i)+&
10545                      wscpho*gvdwc_scpho(j,i)+   &
10546                      wpeppho*gvdwc_peppho(j,i)
10547
10548
10549
10550
10551
10552         enddo
10553       enddo
10554 #else
10555       do i=0,nct
10556         do j=1,3
10557           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10558                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10559                       welec*gelc_long(j,i)+ &
10560                       wbond*gradb(j,i)+ &
10561                       wel_loc*gel_loc_long(j,i)+ &
10562                       wcorr*gradcorr_long(j,i)+ &
10563                       wcorr5*gradcorr5_long(j,i)+ &
10564                       wcorr6*gradcorr6_long(j,i)+ &
10565                       wturn6*gcorr6_turn_long(j,i)+ &
10566                       wstrain*ghpbc(j,i) &
10567                      +wliptran*gliptranc(j,i) &
10568                      +gradafm(j,i) &
10569                      +welec*gshieldc(j,i)&
10570                      +wcorr*gshieldc_ec(j,i) &
10571                      +wturn4*gshieldc_t4(j,i) &
10572                      +wel_loc*gshieldc_ll(j,i)&
10573                      +wtube*gg_tube(j,i) &
10574                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10575                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10576                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10577                      wcorr_nucl*gradcorr_nucl(j,i) &
10578                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10579                      wcatprot* gradpepcat(j,i)+ &
10580                      wcatcat*gradcatcat(j,i)+   &
10581                      wscbase*gvdwc_scbase(j,i)  &
10582                      wpepbase*gvdwc_pepbase(j,i)+&
10583                      wscpho*gvdwc_scpho(j,i)+&
10584                      wpeppho*gvdwc_peppho(j,i)
10585
10586
10587         enddo
10588       enddo
10589 #endif
10590 #ifdef MPI
10591       if (nfgtasks.gt.1) then
10592       time00=MPI_Wtime()
10593 #ifdef DEBUG
10594       write (iout,*) "gradbufc before allreduce"
10595       do i=1,nres
10596         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10597       enddo
10598       call flush(iout)
10599 #endif
10600       do i=0,nres
10601         do j=1,3
10602           gradbufc_sum(j,i)=gradbufc(j,i)
10603         enddo
10604       enddo
10605 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10606 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10607 !      time_reduce=time_reduce+MPI_Wtime()-time00
10608 #ifdef DEBUG
10609 !      write (iout,*) "gradbufc_sum after allreduce"
10610 !      do i=1,nres
10611 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10612 !      enddo
10613 !      call flush(iout)
10614 #endif
10615 #ifdef TIMING
10616 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10617 #endif
10618       do i=0,nres
10619         do k=1,3
10620           gradbufc(k,i)=0.0d0
10621         enddo
10622       enddo
10623 #ifdef DEBUG
10624       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10625       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10626                         " jgrad_end  ",jgrad_end(i),&
10627                         i=igrad_start,igrad_end)
10628 #endif
10629 !
10630 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10631 ! do not parallelize this part.
10632 !
10633 !      do i=igrad_start,igrad_end
10634 !        do j=jgrad_start(i),jgrad_end(i)
10635 !          do k=1,3
10636 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10637 !          enddo
10638 !        enddo
10639 !      enddo
10640       do j=1,3
10641         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10642       enddo
10643       do i=nres-2,-1,-1
10644         do j=1,3
10645           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10646         enddo
10647       enddo
10648 #ifdef DEBUG
10649       write (iout,*) "gradbufc after summing"
10650       do i=1,nres
10651         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10652       enddo
10653       call flush(iout)
10654 #endif
10655       else
10656 #endif
10657 !el#define DEBUG
10658 #ifdef DEBUG
10659       write (iout,*) "gradbufc"
10660       do i=1,nres
10661         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10662       enddo
10663       call flush(iout)
10664 #endif
10665 !el#undef DEBUG
10666       do i=-1,nres
10667         do j=1,3
10668           gradbufc_sum(j,i)=gradbufc(j,i)
10669           gradbufc(j,i)=0.0d0
10670         enddo
10671       enddo
10672       do j=1,3
10673         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10674       enddo
10675       do i=nres-2,-1,-1
10676         do j=1,3
10677           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10678         enddo
10679       enddo
10680 !      do i=nnt,nres-1
10681 !        do k=1,3
10682 !          gradbufc(k,i)=0.0d0
10683 !        enddo
10684 !        do j=i+1,nres
10685 !          do k=1,3
10686 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10687 !          enddo
10688 !        enddo
10689 !      enddo
10690 !el#define DEBUG
10691 #ifdef DEBUG
10692       write (iout,*) "gradbufc after summing"
10693       do i=1,nres
10694         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10695       enddo
10696       call flush(iout)
10697 #endif
10698 !el#undef DEBUG
10699 #ifdef MPI
10700       endif
10701 #endif
10702       do k=1,3
10703         gradbufc(k,nres)=0.0d0
10704       enddo
10705 !el----------------
10706 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10707 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10708 !el-----------------
10709       do i=-1,nct
10710         do j=1,3
10711 #ifdef SPLITELE
10712           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10713                       wel_loc*gel_loc(j,i)+ &
10714                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10715                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10716                       wel_loc*gel_loc_long(j,i)+ &
10717                       wcorr*gradcorr_long(j,i)+ &
10718                       wcorr5*gradcorr5_long(j,i)+ &
10719                       wcorr6*gradcorr6_long(j,i)+ &
10720                       wturn6*gcorr6_turn_long(j,i))+ &
10721                       wbond*gradb(j,i)+ &
10722                       wcorr*gradcorr(j,i)+ &
10723                       wturn3*gcorr3_turn(j,i)+ &
10724                       wturn4*gcorr4_turn(j,i)+ &
10725                       wcorr5*gradcorr5(j,i)+ &
10726                       wcorr6*gradcorr6(j,i)+ &
10727                       wturn6*gcorr6_turn(j,i)+ &
10728                       wsccor*gsccorc(j,i) &
10729                      +wscloc*gscloc(j,i)  &
10730                      +wliptran*gliptranc(j,i) &
10731                      +gradafm(j,i) &
10732                      +welec*gshieldc(j,i) &
10733                      +welec*gshieldc_loc(j,i) &
10734                      +wcorr*gshieldc_ec(j,i) &
10735                      +wcorr*gshieldc_loc_ec(j,i) &
10736                      +wturn3*gshieldc_t3(j,i) &
10737                      +wturn3*gshieldc_loc_t3(j,i) &
10738                      +wturn4*gshieldc_t4(j,i) &
10739                      +wturn4*gshieldc_loc_t4(j,i) &
10740                      +wel_loc*gshieldc_ll(j,i) &
10741                      +wel_loc*gshieldc_loc_ll(j,i) &
10742                      +wtube*gg_tube(j,i) &
10743                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10744                      +wvdwpsb*gvdwpsb1(j,i))&
10745                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10746
10747 !                 if ((i.le.2).and.(i.ge.1))
10748 !                       print *,gradc(j,i,icg),&
10749 !                      gradbufc(j,i),welec*gelc(j,i), &
10750 !                      wel_loc*gel_loc(j,i), &
10751 !                      wscp*gvdwc_scpp(j,i), &
10752 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10753 !                      wel_loc*gel_loc_long(j,i), &
10754 !                      wcorr*gradcorr_long(j,i), &
10755 !                      wcorr5*gradcorr5_long(j,i), &
10756 !                      wcorr6*gradcorr6_long(j,i), &
10757 !                      wturn6*gcorr6_turn_long(j,i), &
10758 !                      wbond*gradb(j,i), &
10759 !                      wcorr*gradcorr(j,i), &
10760 !                      wturn3*gcorr3_turn(j,i), &
10761 !                      wturn4*gcorr4_turn(j,i), &
10762 !                      wcorr5*gradcorr5(j,i), &
10763 !                      wcorr6*gradcorr6(j,i), &
10764 !                      wturn6*gcorr6_turn(j,i), &
10765 !                      wsccor*gsccorc(j,i) &
10766 !                     ,wscloc*gscloc(j,i)  &
10767 !                     ,wliptran*gliptranc(j,i) &
10768 !                    ,gradafm(j,i) &
10769 !                     ,welec*gshieldc(j,i) &
10770 !                     ,welec*gshieldc_loc(j,i) &
10771 !                     ,wcorr*gshieldc_ec(j,i) &
10772 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10773 !                     ,wturn3*gshieldc_t3(j,i) &
10774 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10775 !                     ,wturn4*gshieldc_t4(j,i) &
10776 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10777 !                     ,wel_loc*gshieldc_ll(j,i) &
10778 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10779 !                     ,wtube*gg_tube(j,i) &
10780 !                     ,wbond_nucl*gradb_nucl(j,i) &
10781 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10782 !                     wvdwpsb*gvdwpsb1(j,i)&
10783 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10784 !
10785
10786 #else
10787           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10788                       wel_loc*gel_loc(j,i)+ &
10789                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10790                       welec*gelc_long(j,i)+ &
10791                       wel_loc*gel_loc_long(j,i)+ &
10792 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10793                       wcorr5*gradcorr5_long(j,i)+ &
10794                       wcorr6*gradcorr6_long(j,i)+ &
10795                       wturn6*gcorr6_turn_long(j,i))+ &
10796                       wbond*gradb(j,i)+ &
10797                       wcorr*gradcorr(j,i)+ &
10798                       wturn3*gcorr3_turn(j,i)+ &
10799                       wturn4*gcorr4_turn(j,i)+ &
10800                       wcorr5*gradcorr5(j,i)+ &
10801                       wcorr6*gradcorr6(j,i)+ &
10802                       wturn6*gcorr6_turn(j,i)+ &
10803                       wsccor*gsccorc(j,i) &
10804                      +wscloc*gscloc(j,i) &
10805                      +gradafm(j,i) &
10806                      +wliptran*gliptranc(j,i) &
10807                      +welec*gshieldc(j,i) &
10808                      +welec*gshieldc_loc(j,) &
10809                      +wcorr*gshieldc_ec(j,i) &
10810                      +wcorr*gshieldc_loc_ec(j,i) &
10811                      +wturn3*gshieldc_t3(j,i) &
10812                      +wturn3*gshieldc_loc_t3(j,i) &
10813                      +wturn4*gshieldc_t4(j,i) &
10814                      +wturn4*gshieldc_loc_t4(j,i) &
10815                      +wel_loc*gshieldc_ll(j,i) &
10816                      +wel_loc*gshieldc_loc_ll(j,i) &
10817                      +wtube*gg_tube(j,i) &
10818                      +wbond_nucl*gradb_nucl(j,i) &
10819                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10820                      +wvdwpsb*gvdwpsb1(j,i))&
10821                      +wsbloc*gsbloc(j,i)
10822
10823
10824
10825
10826 #endif
10827           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10828                         wbond*gradbx(j,i)+ &
10829                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10830                         wsccor*gsccorx(j,i) &
10831                        +wscloc*gsclocx(j,i) &
10832                        +wliptran*gliptranx(j,i) &
10833                        +welec*gshieldx(j,i)     &
10834                        +wcorr*gshieldx_ec(j,i)  &
10835                        +wturn3*gshieldx_t3(j,i) &
10836                        +wturn4*gshieldx_t4(j,i) &
10837                        +wel_loc*gshieldx_ll(j,i)&
10838                        +wtube*gg_tube_sc(j,i)   &
10839                        +wbond_nucl*gradbx_nucl(j,i) &
10840                        +wvdwsb*gvdwsbx(j,i) &
10841                        +welsb*gelsbx(j,i) &
10842                        +wcorr_nucl*gradxorr_nucl(j,i)&
10843                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10844                        +wsbloc*gsblocx(j,i) &
10845                        +wcatprot* gradpepcatx(j,i)&
10846                        +wscbase*gvdwx_scbase(j,i) &
10847                        +wpepbase*gvdwx_pepbase(j,i)&
10848                        +wscpho*gvdwx_scpho(j,i)
10849 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
10850
10851         enddo
10852       enddo
10853 #ifdef DEBUG
10854       write (iout,*) "gloc before adding corr"
10855       do i=1,4*nres
10856         write (iout,*) i,gloc(i,icg)
10857       enddo
10858 #endif
10859       do i=1,nres-3
10860         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10861          +wcorr5*g_corr5_loc(i) &
10862          +wcorr6*g_corr6_loc(i) &
10863          +wturn4*gel_loc_turn4(i) &
10864          +wturn3*gel_loc_turn3(i) &
10865          +wturn6*gel_loc_turn6(i) &
10866          +wel_loc*gel_loc_loc(i)
10867       enddo
10868 #ifdef DEBUG
10869       write (iout,*) "gloc after adding corr"
10870       do i=1,4*nres
10871         write (iout,*) i,gloc(i,icg)
10872       enddo
10873 #endif
10874 #ifdef MPI
10875       if (nfgtasks.gt.1) then
10876         do j=1,3
10877           do i=0,nres
10878             gradbufc(j,i)=gradc(j,i,icg)
10879             gradbufx(j,i)=gradx(j,i,icg)
10880           enddo
10881         enddo
10882         do i=1,4*nres
10883           glocbuf(i)=gloc(i,icg)
10884         enddo
10885 !#define DEBUG
10886 #ifdef DEBUG
10887       write (iout,*) "gloc_sc before reduce"
10888       do i=1,nres
10889        do j=1,1
10890         write (iout,*) i,j,gloc_sc(j,i,icg)
10891        enddo
10892       enddo
10893 #endif
10894 !#undef DEBUG
10895         do i=1,nres
10896          do j=1,3
10897           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10898          enddo
10899         enddo
10900         time00=MPI_Wtime()
10901         call MPI_Barrier(FG_COMM,IERR)
10902         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10903         time00=MPI_Wtime()
10904         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10905           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10906         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10907           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10908         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10909           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10910         time_reduce=time_reduce+MPI_Wtime()-time00
10911         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10912           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10913         time_reduce=time_reduce+MPI_Wtime()-time00
10914 !#define DEBUG
10915 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10916 #ifdef DEBUG
10917       write (iout,*) "gloc_sc after reduce"
10918       do i=1,nres
10919        do j=1,1
10920         write (iout,*) i,j,gloc_sc(j,i,icg)
10921        enddo
10922       enddo
10923 #endif
10924 !#undef DEBUG
10925 #ifdef DEBUG
10926       write (iout,*) "gloc after reduce"
10927       do i=1,4*nres
10928         write (iout,*) i,gloc(i,icg)
10929       enddo
10930 #endif
10931       endif
10932 #endif
10933       if (gnorm_check) then
10934 !
10935 ! Compute the maximum elements of the gradient
10936 !
10937       gvdwc_max=0.0d0
10938       gvdwc_scp_max=0.0d0
10939       gelc_max=0.0d0
10940       gvdwpp_max=0.0d0
10941       gradb_max=0.0d0
10942       ghpbc_max=0.0d0
10943       gradcorr_max=0.0d0
10944       gel_loc_max=0.0d0
10945       gcorr3_turn_max=0.0d0
10946       gcorr4_turn_max=0.0d0
10947       gradcorr5_max=0.0d0
10948       gradcorr6_max=0.0d0
10949       gcorr6_turn_max=0.0d0
10950       gsccorc_max=0.0d0
10951       gscloc_max=0.0d0
10952       gvdwx_max=0.0d0
10953       gradx_scp_max=0.0d0
10954       ghpbx_max=0.0d0
10955       gradxorr_max=0.0d0
10956       gsccorx_max=0.0d0
10957       gsclocx_max=0.0d0
10958       do i=1,nct
10959         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10960         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10961         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10962         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10963          gvdwc_scp_max=gvdwc_scp_norm
10964         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10965         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10966         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10967         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10968         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10969         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10970         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10971         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10972         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10973         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10974         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10975         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10976         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10977           gcorr3_turn(1,i)))
10978         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10979           gcorr3_turn_max=gcorr3_turn_norm
10980         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10981           gcorr4_turn(1,i)))
10982         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10983           gcorr4_turn_max=gcorr4_turn_norm
10984         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10985         if (gradcorr5_norm.gt.gradcorr5_max) &
10986           gradcorr5_max=gradcorr5_norm
10987         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10988         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10989         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10990           gcorr6_turn(1,i)))
10991         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10992           gcorr6_turn_max=gcorr6_turn_norm
10993         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10994         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10995         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10996         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10997         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10998         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10999         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11000         if (gradx_scp_norm.gt.gradx_scp_max) &
11001           gradx_scp_max=gradx_scp_norm
11002         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11003         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11004         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11005         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11006         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11007         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11008         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11009         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11010       enddo
11011       if (gradout) then
11012 #ifdef AIX
11013         open(istat,file=statname,position="append")
11014 #else
11015         open(istat,file=statname,access="append")
11016 #endif
11017         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11018            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11019            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11020            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11021            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11022            gsccorx_max,gsclocx_max
11023         close(istat)
11024         if (gvdwc_max.gt.1.0d4) then
11025           write (iout,*) "gvdwc gvdwx gradb gradbx"
11026           do i=nnt,nct
11027             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11028               gradb(j,i),gradbx(j,i),j=1,3)
11029           enddo
11030           call pdbout(0.0d0,'cipiszcze',iout)
11031           call flush(iout)
11032         endif
11033       endif
11034       endif
11035 !el#define DEBUG
11036 #ifdef DEBUG
11037       write (iout,*) "gradc gradx gloc"
11038       do i=1,nres
11039         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11040          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11041       enddo
11042 #endif
11043 !el#undef DEBUG
11044 #ifdef TIMING
11045       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11046 #endif
11047       return
11048       end subroutine sum_gradient
11049 !-----------------------------------------------------------------------------
11050       subroutine sc_grad
11051 !      implicit real*8 (a-h,o-z)
11052       use calc_data
11053 !      include 'DIMENSIONS'
11054 !      include 'COMMON.CHAIN'
11055 !      include 'COMMON.DERIV'
11056 !      include 'COMMON.CALC'
11057 !      include 'COMMON.IOUNITS'
11058       real(kind=8), dimension(3) :: dcosom1,dcosom2
11059 !      print *,"wchodze"
11060       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
11061       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
11062       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11063            -2.0D0*alf12*eps3der+sigder*sigsq_om12
11064 ! diagnostics only
11065 !      eom1=0.0d0
11066 !      eom2=0.0d0
11067 !      eom12=evdwij*eps1_om12
11068 ! end diagnostics
11069 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11070 !       " sigder",sigder
11071 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11072 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11073 !C      print *,sss_ele_cut,'in sc_grad'
11074       do k=1,3
11075         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11076         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11077       enddo
11078       do k=1,3
11079         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11080 !C      print *,'gg',k,gg(k)
11081        enddo
11082 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11083 !      write (iout,*) "gg",(gg(k),k=1,3)
11084       do k=1,3
11085         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11086                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11087                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11088                   *sss_ele_cut
11089
11090         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11091                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11092                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11093                   *sss_ele_cut
11094
11095 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11096 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11097 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11098 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11099       enddo
11100 !
11101 ! Calculate the components of the gradient in DC and X
11102 !
11103 !grad      do k=i,j-1
11104 !grad        do l=1,3
11105 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11106 !grad        enddo
11107 !grad      enddo
11108       do l=1,3
11109         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11110         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11111       enddo
11112       return
11113       end subroutine sc_grad
11114 #ifdef CRYST_THETA
11115 !-----------------------------------------------------------------------------
11116       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11117
11118       use comm_calcthet
11119 !      implicit real*8 (a-h,o-z)
11120 !      include 'DIMENSIONS'
11121 !      include 'COMMON.LOCAL'
11122 !      include 'COMMON.IOUNITS'
11123 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11124 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11125 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11126       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11127       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11128 !el      integer :: it
11129 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11130 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11131 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11132 !el local variables
11133
11134       delthec=thetai-thet_pred_mean
11135       delthe0=thetai-theta0i
11136 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11137       t3 = thetai-thet_pred_mean
11138       t6 = t3**2
11139       t9 = term1
11140       t12 = t3*sigcsq
11141       t14 = t12+t6*sigsqtc
11142       t16 = 1.0d0
11143       t21 = thetai-theta0i
11144       t23 = t21**2
11145       t26 = term2
11146       t27 = t21*t26
11147       t32 = termexp
11148       t40 = t32**2
11149       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11150        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11151        *(-t12*t9-ak*sig0inv*t27)
11152       return
11153       end subroutine mixder
11154 #endif
11155 !-----------------------------------------------------------------------------
11156 ! cartder.F
11157 !-----------------------------------------------------------------------------
11158       subroutine cartder
11159 !-----------------------------------------------------------------------------
11160 ! This subroutine calculates the derivatives of the consecutive virtual
11161 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11162 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11163 ! in the angles alpha and omega, describing the location of a side chain
11164 ! in its local coordinate system.
11165 !
11166 ! The derivatives are stored in the following arrays:
11167 !
11168 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11169 ! The structure is as follows:
11170 !
11171 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11172 ! 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)
11173 !         . . . . . . . . . . . .  . . . . . .
11174 ! 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)
11175 !                          .
11176 !                          .
11177 !                          .
11178 ! 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)
11179 !
11180 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11181 ! The structure is same as above.
11182 !
11183 ! DCDS - the derivatives of the side chain vectors in the local spherical
11184 ! andgles alph and omega:
11185 !
11186 ! 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)
11187 ! 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)
11188 !                          .
11189 !                          .
11190 !                          .
11191 ! 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)
11192 !
11193 ! Version of March '95, based on an early version of November '91.
11194 !
11195 !**********************************************************************
11196 !      implicit real*8 (a-h,o-z)
11197 !      include 'DIMENSIONS'
11198 !      include 'COMMON.VAR'
11199 !      include 'COMMON.CHAIN'
11200 !      include 'COMMON.DERIV'
11201 !      include 'COMMON.GEO'
11202 !      include 'COMMON.LOCAL'
11203 !      include 'COMMON.INTERACT'
11204       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11205       real(kind=8),dimension(3,3) :: dp,temp
11206 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11207       real(kind=8),dimension(3) :: xx,xx1
11208 !el local variables
11209       integer :: i,k,l,j,m,ind,ind1,jjj
11210       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11211                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11212                  sint2,xp,yp,xxp,yyp,zzp,dj
11213
11214 !      common /przechowalnia/ fromto
11215       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11216 ! get the position of the jth ijth fragment of the chain coordinate system
11217 ! in the fromto array.
11218 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11219 !
11220 !      maxdim=(nres-1)*(nres-2)/2
11221 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11222 ! calculate the derivatives of transformation matrix elements in theta
11223 !
11224
11225 !el      call flush(iout) !el
11226       do i=1,nres-2
11227         rdt(1,1,i)=-rt(1,2,i)
11228         rdt(1,2,i)= rt(1,1,i)
11229         rdt(1,3,i)= 0.0d0
11230         rdt(2,1,i)=-rt(2,2,i)
11231         rdt(2,2,i)= rt(2,1,i)
11232         rdt(2,3,i)= 0.0d0
11233         rdt(3,1,i)=-rt(3,2,i)
11234         rdt(3,2,i)= rt(3,1,i)
11235         rdt(3,3,i)= 0.0d0
11236       enddo
11237 !
11238 ! derivatives in phi
11239 !
11240       do i=2,nres-2
11241         drt(1,1,i)= 0.0d0
11242         drt(1,2,i)= 0.0d0
11243         drt(1,3,i)= 0.0d0
11244         drt(2,1,i)= rt(3,1,i)
11245         drt(2,2,i)= rt(3,2,i)
11246         drt(2,3,i)= rt(3,3,i)
11247         drt(3,1,i)=-rt(2,1,i)
11248         drt(3,2,i)=-rt(2,2,i)
11249         drt(3,3,i)=-rt(2,3,i)
11250       enddo
11251 !
11252 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11253 !
11254       do i=2,nres-2
11255         ind=indmat(i,i+1)
11256         do k=1,3
11257           do l=1,3
11258             temp(k,l)=rt(k,l,i)
11259           enddo
11260         enddo
11261         do k=1,3
11262           do l=1,3
11263             fromto(k,l,ind)=temp(k,l)
11264           enddo
11265         enddo
11266         do j=i+1,nres-2
11267           ind=indmat(i,j+1)
11268           do k=1,3
11269             do l=1,3
11270               dpkl=0.0d0
11271               do m=1,3
11272                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11273               enddo
11274               dp(k,l)=dpkl
11275               fromto(k,l,ind)=dpkl
11276             enddo
11277           enddo
11278           do k=1,3
11279             do l=1,3
11280               temp(k,l)=dp(k,l)
11281             enddo
11282           enddo
11283         enddo
11284       enddo
11285 !
11286 ! Calculate derivatives.
11287 !
11288       ind1=0
11289       do i=1,nres-2
11290       ind1=ind1+1
11291 !
11292 ! Derivatives of DC(i+1) in theta(i+2)
11293 !
11294         do j=1,3
11295           do k=1,2
11296             dpjk=0.0D0
11297             do l=1,3
11298               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11299             enddo
11300             dp(j,k)=dpjk
11301             prordt(j,k,i)=dp(j,k)
11302           enddo
11303           dp(j,3)=0.0D0
11304           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11305         enddo
11306 !
11307 ! Derivatives of SC(i+1) in theta(i+2)
11308 !
11309         xx1(1)=-0.5D0*xloc(2,i+1)
11310         xx1(2)= 0.5D0*xloc(1,i+1)
11311         do j=1,3
11312           xj=0.0D0
11313           do k=1,2
11314             xj=xj+r(j,k,i)*xx1(k)
11315           enddo
11316           xx(j)=xj
11317         enddo
11318         do j=1,3
11319           rj=0.0D0
11320           do k=1,3
11321             rj=rj+prod(j,k,i)*xx(k)
11322           enddo
11323           dxdv(j,ind1)=rj
11324         enddo
11325 !
11326 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11327 ! than the other off-diagonal derivatives.
11328 !
11329         do j=1,3
11330           dxoiij=0.0D0
11331           do k=1,3
11332             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11333           enddo
11334           dxdv(j,ind1+1)=dxoiij
11335         enddo
11336 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11337 !
11338 ! Derivatives of DC(i+1) in phi(i+2)
11339 !
11340         do j=1,3
11341           do k=1,3
11342             dpjk=0.0
11343             do l=2,3
11344               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11345             enddo
11346             dp(j,k)=dpjk
11347             prodrt(j,k,i)=dp(j,k)
11348           enddo
11349           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11350         enddo
11351 !
11352 ! Derivatives of SC(i+1) in phi(i+2)
11353 !
11354         xx(1)= 0.0D0
11355         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11356         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11357         do j=1,3
11358           rj=0.0D0
11359           do k=2,3
11360             rj=rj+prod(j,k,i)*xx(k)
11361           enddo
11362           dxdv(j+3,ind1)=-rj
11363         enddo
11364 !
11365 ! Derivatives of SC(i+1) in phi(i+3).
11366 !
11367         do j=1,3
11368           dxoiij=0.0D0
11369           do k=1,3
11370             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11371           enddo
11372           dxdv(j+3,ind1+1)=dxoiij
11373         enddo
11374 !
11375 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11376 ! theta(nres) and phi(i+3) thru phi(nres).
11377 !
11378         do j=i+1,nres-2
11379         ind1=ind1+1
11380         ind=indmat(i+1,j+1)
11381 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11382           do k=1,3
11383             do l=1,3
11384               tempkl=0.0D0
11385               do m=1,2
11386                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11387               enddo
11388               temp(k,l)=tempkl
11389             enddo
11390           enddo
11391 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11392 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11393 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11394 ! Derivatives of virtual-bond vectors in theta
11395           do k=1,3
11396             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11397           enddo
11398 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11399 ! Derivatives of SC vectors in theta
11400           do k=1,3
11401             dxoijk=0.0D0
11402             do l=1,3
11403               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11404             enddo
11405             dxdv(k,ind1+1)=dxoijk
11406           enddo
11407 !
11408 !--- Calculate the derivatives in phi
11409 !
11410           do k=1,3
11411             do l=1,3
11412               tempkl=0.0D0
11413               do m=1,3
11414                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11415               enddo
11416               temp(k,l)=tempkl
11417             enddo
11418           enddo
11419           do k=1,3
11420             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11421         enddo
11422           do k=1,3
11423             dxoijk=0.0D0
11424             do l=1,3
11425               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11426             enddo
11427             dxdv(k+3,ind1+1)=dxoijk
11428           enddo
11429         enddo
11430       enddo
11431 !
11432 ! Derivatives in alpha and omega:
11433 !
11434       do i=2,nres-1
11435 !       dsci=dsc(itype(i,1))
11436         dsci=vbld(i+nres)
11437 #ifdef OSF
11438         alphi=alph(i)
11439         omegi=omeg(i)
11440         if(alphi.ne.alphi) alphi=100.0
11441         if(omegi.ne.omegi) omegi=-100.0
11442 #else
11443       alphi=alph(i)
11444       omegi=omeg(i)
11445 #endif
11446 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11447       cosalphi=dcos(alphi)
11448       sinalphi=dsin(alphi)
11449       cosomegi=dcos(omegi)
11450       sinomegi=dsin(omegi)
11451       temp(1,1)=-dsci*sinalphi
11452       temp(2,1)= dsci*cosalphi*cosomegi
11453       temp(3,1)=-dsci*cosalphi*sinomegi
11454       temp(1,2)=0.0D0
11455       temp(2,2)=-dsci*sinalphi*sinomegi
11456       temp(3,2)=-dsci*sinalphi*cosomegi
11457       theta2=pi-0.5D0*theta(i+1)
11458       cost2=dcos(theta2)
11459       sint2=dsin(theta2)
11460       jjj=0
11461 !d      print *,((temp(l,k),l=1,3),k=1,2)
11462         do j=1,2
11463         xp=temp(1,j)
11464         yp=temp(2,j)
11465         xxp= xp*cost2+yp*sint2
11466         yyp=-xp*sint2+yp*cost2
11467         zzp=temp(3,j)
11468         xx(1)=xxp
11469         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11470         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11471         do k=1,3
11472           dj=0.0D0
11473           do l=1,3
11474             dj=dj+prod(k,l,i-1)*xx(l)
11475             enddo
11476           dxds(jjj+k,i)=dj
11477           enddo
11478         jjj=jjj+3
11479       enddo
11480       enddo
11481       return
11482       end subroutine cartder
11483 !-----------------------------------------------------------------------------
11484 ! checkder_p.F
11485 !-----------------------------------------------------------------------------
11486       subroutine check_cartgrad
11487 ! Check the gradient of Cartesian coordinates in internal coordinates.
11488 !      implicit real*8 (a-h,o-z)
11489 !      include 'DIMENSIONS'
11490 !      include 'COMMON.IOUNITS'
11491 !      include 'COMMON.VAR'
11492 !      include 'COMMON.CHAIN'
11493 !      include 'COMMON.GEO'
11494 !      include 'COMMON.LOCAL'
11495 !      include 'COMMON.DERIV'
11496       real(kind=8),dimension(6,nres) :: temp
11497       real(kind=8),dimension(3) :: xx,gg
11498       integer :: i,k,j,ii
11499       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11500 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11501 !
11502 ! Check the gradient of the virtual-bond and SC vectors in the internal
11503 ! coordinates.
11504 !
11505       aincr=1.0d-6
11506       aincr2=5.0d-7
11507       call cartder
11508       write (iout,'(a)') '**************** dx/dalpha'
11509       write (iout,'(a)')
11510       do i=2,nres-1
11511       alphi=alph(i)
11512       alph(i)=alph(i)+aincr
11513       do k=1,3
11514         temp(k,i)=dc(k,nres+i)
11515         enddo
11516       call chainbuild
11517       do k=1,3
11518         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11519         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11520         enddo
11521         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11522         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11523         write (iout,'(a)')
11524       alph(i)=alphi
11525       call chainbuild
11526       enddo
11527       write (iout,'(a)')
11528       write (iout,'(a)') '**************** dx/domega'
11529       write (iout,'(a)')
11530       do i=2,nres-1
11531       omegi=omeg(i)
11532       omeg(i)=omeg(i)+aincr
11533       do k=1,3
11534         temp(k,i)=dc(k,nres+i)
11535         enddo
11536       call chainbuild
11537       do k=1,3
11538           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11539           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11540                 (aincr*dabs(dxds(k+3,i))+aincr))
11541         enddo
11542         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11543             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11544         write (iout,'(a)')
11545       omeg(i)=omegi
11546       call chainbuild
11547       enddo
11548       write (iout,'(a)')
11549       write (iout,'(a)') '**************** dx/dtheta'
11550       write (iout,'(a)')
11551       do i=3,nres
11552       theti=theta(i)
11553         theta(i)=theta(i)+aincr
11554         do j=i-1,nres-1
11555           do k=1,3
11556             temp(k,j)=dc(k,nres+j)
11557           enddo
11558         enddo
11559         call chainbuild
11560         do j=i-1,nres-1
11561         ii = indmat(i-2,j)
11562 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11563         do k=1,3
11564           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11565           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11566                   (aincr*dabs(dxdv(k,ii))+aincr))
11567           enddo
11568           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11569               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11570           write(iout,'(a)')
11571         enddo
11572         write (iout,'(a)')
11573         theta(i)=theti
11574         call chainbuild
11575       enddo
11576       write (iout,'(a)') '***************** dx/dphi'
11577       write (iout,'(a)')
11578       do i=4,nres
11579         phi(i)=phi(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 *,'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+3,ii))/ &
11592                   (aincr*dabs(dxdv(k+3,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+3,ii),k=1,3),(xx(k),k=1,3)
11596           write(iout,'(a)')
11597         enddo
11598         phi(i)=phi(i)-aincr
11599         call chainbuild
11600       enddo
11601       write (iout,'(a)') '****************** ddc/dtheta'
11602       do i=1,nres-2
11603         thet=theta(i+2)
11604         theta(i+2)=thet+aincr
11605         do j=i,nres
11606           do k=1,3
11607             temp(k,j)=dc(k,j)
11608           enddo
11609         enddo
11610         call chainbuild
11611         do j=i+1,nres-1
11612         ii = indmat(i,j)
11613 !         print *,'ii=',ii
11614         do k=1,3
11615           gg(k)=(dc(k,j)-temp(k,j))/aincr
11616           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11617                  (aincr*dabs(dcdv(k,ii))+aincr))
11618           enddo
11619           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11620                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11621         write (iout,'(a)')
11622         enddo
11623         do j=1,nres
11624           do k=1,3
11625             dc(k,j)=temp(k,j)
11626           enddo
11627         enddo
11628         theta(i+2)=thet
11629       enddo
11630       write (iout,'(a)') '******************* ddc/dphi'
11631       do i=1,nres-3
11632         phii=phi(i+3)
11633         phi(i+3)=phii+aincr
11634         do j=1,nres
11635           do k=1,3
11636             temp(k,j)=dc(k,j)
11637           enddo
11638         enddo
11639         call chainbuild
11640         do j=i+2,nres-1
11641         ii = indmat(i+1,j)
11642 !         print *,'ii=',ii
11643         do k=1,3
11644           gg(k)=(dc(k,j)-temp(k,j))/aincr
11645             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11646                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11647           enddo
11648           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11649                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11650         write (iout,'(a)')
11651         enddo
11652         do j=1,nres
11653           do k=1,3
11654             dc(k,j)=temp(k,j)
11655           enddo
11656         enddo
11657         phi(i+3)=phii
11658       enddo
11659       return
11660       end subroutine check_cartgrad
11661 !-----------------------------------------------------------------------------
11662       subroutine check_ecart
11663 ! Check the gradient of the energy in Cartesian coordinates.
11664 !     implicit real*8 (a-h,o-z)
11665 !     include 'DIMENSIONS'
11666 !     include 'COMMON.CHAIN'
11667 !     include 'COMMON.DERIV'
11668 !     include 'COMMON.IOUNITS'
11669 !     include 'COMMON.VAR'
11670 !     include 'COMMON.CONTACTS'
11671       use comm_srutu
11672 !el      integer :: icall
11673 !el      common /srutu/ icall
11674       real(kind=8),dimension(6) :: ggg
11675       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11676       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11677       real(kind=8),dimension(6,nres) :: grad_s
11678       real(kind=8),dimension(0:n_ene) :: energia,energia1
11679       integer :: uiparm(1)
11680       real(kind=8) :: urparm(1)
11681 !EL      external fdum
11682       integer :: nf,i,j,k
11683       real(kind=8) :: aincr,etot,etot1
11684       icg=1
11685       nf=0
11686       nfl=0
11687       call zerograd
11688       aincr=1.0D-5
11689       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11690       nf=0
11691       icall=0
11692       call geom_to_var(nvar,x)
11693       call etotal(energia)
11694       etot=energia(0)
11695 !el      call enerprint(energia)
11696       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11697       icall =1
11698       do i=1,nres
11699         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11700       enddo
11701       do i=1,nres
11702       do j=1,3
11703         grad_s(j,i)=gradc(j,i,icg)
11704         grad_s(j+3,i)=gradx(j,i,icg)
11705         enddo
11706       enddo
11707       call flush(iout)
11708       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11709       do i=1,nres
11710         do j=1,3
11711         xx(j)=c(j,i+nres)
11712         ddc(j)=dc(j,i)
11713         ddx(j)=dc(j,i+nres)
11714         enddo
11715       do j=1,3
11716         dc(j,i)=dc(j,i)+aincr
11717         do k=i+1,nres
11718           c(j,k)=c(j,k)+aincr
11719           c(j,k+nres)=c(j,k+nres)+aincr
11720           enddo
11721           call etotal(energia1)
11722           etot1=energia1(0)
11723         ggg(j)=(etot1-etot)/aincr
11724         dc(j,i)=ddc(j)
11725         do k=i+1,nres
11726           c(j,k)=c(j,k)-aincr
11727           c(j,k+nres)=c(j,k+nres)-aincr
11728           enddo
11729         enddo
11730       do j=1,3
11731         c(j,i+nres)=c(j,i+nres)+aincr
11732         dc(j,i+nres)=dc(j,i+nres)+aincr
11733           call etotal(energia1)
11734           etot1=energia1(0)
11735         ggg(j+3)=(etot1-etot)/aincr
11736         c(j,i+nres)=xx(j)
11737         dc(j,i+nres)=ddx(j)
11738         enddo
11739       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11740          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11741       enddo
11742       return
11743       end subroutine check_ecart
11744 #ifdef CARGRAD
11745 !-----------------------------------------------------------------------------
11746       subroutine check_ecartint
11747 ! Check the gradient of the energy in Cartesian coordinates.
11748       use io_base, only: intout
11749 !      implicit real*8 (a-h,o-z)
11750 !      include 'DIMENSIONS'
11751 !      include 'COMMON.CONTROL'
11752 !      include 'COMMON.CHAIN'
11753 !      include 'COMMON.DERIV'
11754 !      include 'COMMON.IOUNITS'
11755 !      include 'COMMON.VAR'
11756 !      include 'COMMON.CONTACTS'
11757 !      include 'COMMON.MD'
11758 !      include 'COMMON.LOCAL'
11759 !      include 'COMMON.SPLITELE'
11760       use comm_srutu
11761 !el      integer :: icall
11762 !el      common /srutu/ icall
11763       real(kind=8),dimension(6) :: ggg,ggg1
11764       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11765       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11766       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11767       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11768       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11769       real(kind=8),dimension(0:n_ene) :: energia,energia1
11770       integer :: uiparm(1)
11771       real(kind=8) :: urparm(1)
11772 !EL      external fdum
11773       integer :: i,j,k,nf
11774       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11775                    etot21,etot22
11776       r_cut=2.0d0
11777       rlambd=0.3d0
11778       icg=1
11779       nf=0
11780       nfl=0
11781       call intout
11782 !      call intcartderiv
11783 !      call checkintcartgrad
11784       call zerograd
11785       aincr=1.0D-5
11786       write(iout,*) 'Calling CHECK_ECARTINT.'
11787       nf=0
11788       icall=0
11789       write (iout,*) "Before geom_to_var"
11790       call geom_to_var(nvar,x)
11791       write (iout,*) "after geom_to_var"
11792       write (iout,*) "split_ene ",split_ene
11793       call flush(iout)
11794       if (.not.split_ene) then
11795         write(iout,*) 'Calling CHECK_ECARTINT if'
11796         call etotal(energia)
11797 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11798         etot=energia(0)
11799         write (iout,*) "etot",etot
11800         call flush(iout)
11801 !el        call enerprint(energia)
11802 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11803         call flush(iout)
11804         write (iout,*) "enter cartgrad"
11805         call flush(iout)
11806         call cartgrad
11807 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11808         write (iout,*) "exit cartgrad"
11809         call flush(iout)
11810         icall =1
11811         do i=1,nres
11812           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11813         enddo
11814         do j=1,3
11815           grad_s(j,0)=gcart(j,0)
11816         enddo
11817 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11818         do i=1,nres
11819           do j=1,3
11820             grad_s(j,i)=gcart(j,i)
11821             grad_s(j+3,i)=gxcart(j,i)
11822           enddo
11823         enddo
11824       else
11825 write(iout,*) 'Calling CHECK_ECARTIN else.'
11826 !- split gradient check
11827         call zerograd
11828         call etotal_long(energia)
11829 !el        call enerprint(energia)
11830         call flush(iout)
11831         write (iout,*) "enter cartgrad"
11832         call flush(iout)
11833         call cartgrad
11834         write (iout,*) "exit cartgrad"
11835         call flush(iout)
11836         icall =1
11837         write (iout,*) "longrange grad"
11838         do i=1,nres
11839           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11840           (gxcart(j,i),j=1,3)
11841         enddo
11842         do j=1,3
11843           grad_s(j,0)=gcart(j,0)
11844         enddo
11845         do i=1,nres
11846           do j=1,3
11847             grad_s(j,i)=gcart(j,i)
11848             grad_s(j+3,i)=gxcart(j,i)
11849           enddo
11850         enddo
11851         call zerograd
11852         call etotal_short(energia)
11853         call enerprint(energia)
11854         call flush(iout)
11855         write (iout,*) "enter cartgrad"
11856         call flush(iout)
11857         call cartgrad
11858         write (iout,*) "exit cartgrad"
11859         call flush(iout)
11860         icall =1
11861         write (iout,*) "shortrange grad"
11862         do i=1,nres
11863           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11864           (gxcart(j,i),j=1,3)
11865         enddo
11866         do j=1,3
11867           grad_s1(j,0)=gcart(j,0)
11868         enddo
11869         do i=1,nres
11870           do j=1,3
11871             grad_s1(j,i)=gcart(j,i)
11872             grad_s1(j+3,i)=gxcart(j,i)
11873           enddo
11874         enddo
11875       endif
11876       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11877 !      do i=1,nres
11878       do i=nnt,nct
11879         do j=1,3
11880           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11881           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11882         ddc(j)=c(j,i)
11883         ddx(j)=c(j,i+nres)
11884           dcnorm_safe1(j)=dc_norm(j,i-1)
11885           dcnorm_safe2(j)=dc_norm(j,i)
11886           dxnorm_safe(j)=dc_norm(j,i+nres)
11887         enddo
11888       do j=1,3
11889         c(j,i)=ddc(j)+aincr
11890           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11891           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11892           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11893           dc(j,i)=c(j,i+1)-c(j,i)
11894           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11895           call int_from_cart1(.false.)
11896           if (.not.split_ene) then
11897             call etotal(energia1)
11898             etot1=energia1(0)
11899             write (iout,*) "ij",i,j," etot1",etot1
11900           else
11901 !- split gradient
11902             call etotal_long(energia1)
11903             etot11=energia1(0)
11904             call etotal_short(energia1)
11905             etot12=energia1(0)
11906           endif
11907 !- end split gradient
11908 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11909         c(j,i)=ddc(j)-aincr
11910           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11911           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11912           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11913           dc(j,i)=c(j,i+1)-c(j,i)
11914           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11915           call int_from_cart1(.false.)
11916           if (.not.split_ene) then
11917             call etotal(energia1)
11918             etot2=energia1(0)
11919             write (iout,*) "ij",i,j," etot2",etot2
11920           ggg(j)=(etot1-etot2)/(2*aincr)
11921           else
11922 !- split gradient
11923             call etotal_long(energia1)
11924             etot21=energia1(0)
11925           ggg(j)=(etot11-etot21)/(2*aincr)
11926             call etotal_short(energia1)
11927             etot22=energia1(0)
11928           ggg1(j)=(etot12-etot22)/(2*aincr)
11929 !- end split gradient
11930 !            write (iout,*) "etot21",etot21," etot22",etot22
11931           endif
11932 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11933         c(j,i)=ddc(j)
11934           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11935           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11936           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11937           dc(j,i)=c(j,i+1)-c(j,i)
11938           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11939           dc_norm(j,i-1)=dcnorm_safe1(j)
11940           dc_norm(j,i)=dcnorm_safe2(j)
11941           dc_norm(j,i+nres)=dxnorm_safe(j)
11942         enddo
11943       do j=1,3
11944         c(j,i+nres)=ddx(j)+aincr
11945           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11946           call int_from_cart1(.false.)
11947           if (.not.split_ene) then
11948             call etotal(energia1)
11949             etot1=energia1(0)
11950           else
11951 !- split gradient
11952             call etotal_long(energia1)
11953             etot11=energia1(0)
11954             call etotal_short(energia1)
11955             etot12=energia1(0)
11956           endif
11957 !- end split gradient
11958         c(j,i+nres)=ddx(j)-aincr
11959           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11960           call int_from_cart1(.false.)
11961           if (.not.split_ene) then
11962             call etotal(energia1)
11963             etot2=energia1(0)
11964           ggg(j+3)=(etot1-etot2)/(2*aincr)
11965           else
11966 !- split gradient
11967             call etotal_long(energia1)
11968             etot21=energia1(0)
11969           ggg(j+3)=(etot11-etot21)/(2*aincr)
11970             call etotal_short(energia1)
11971             etot22=energia1(0)
11972           ggg1(j+3)=(etot12-etot22)/(2*aincr)
11973 !- end split gradient
11974           endif
11975 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11976         c(j,i+nres)=ddx(j)
11977           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11978           dc_norm(j,i+nres)=dxnorm_safe(j)
11979           call int_from_cart1(.false.)
11980         enddo
11981       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11982          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11983         if (split_ene) then
11984           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11985          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11986          k=1,6)
11987          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11988          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11989          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11990         endif
11991       enddo
11992       return
11993       end subroutine check_ecartint
11994 #else
11995 !-----------------------------------------------------------------------------
11996       subroutine check_ecartint
11997 ! Check the gradient of the energy in Cartesian coordinates.
11998       use io_base, only: intout
11999 !      implicit real*8 (a-h,o-z)
12000 !      include 'DIMENSIONS'
12001 !      include 'COMMON.CONTROL'
12002 !      include 'COMMON.CHAIN'
12003 !      include 'COMMON.DERIV'
12004 !      include 'COMMON.IOUNITS'
12005 !      include 'COMMON.VAR'
12006 !      include 'COMMON.CONTACTS'
12007 !      include 'COMMON.MD'
12008 !      include 'COMMON.LOCAL'
12009 !      include 'COMMON.SPLITELE'
12010       use comm_srutu
12011 !el      integer :: icall
12012 !el      common /srutu/ icall
12013       real(kind=8),dimension(6) :: ggg,ggg1
12014       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12015       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12016       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12017       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12018       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12019       real(kind=8),dimension(0:n_ene) :: energia,energia1
12020       integer :: uiparm(1)
12021       real(kind=8) :: urparm(1)
12022 !EL      external fdum
12023       integer :: i,j,k,nf
12024       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12025                    etot21,etot22
12026       r_cut=2.0d0
12027       rlambd=0.3d0
12028       icg=1
12029       nf=0
12030       nfl=0
12031       call intout
12032 !      call intcartderiv
12033 !      call checkintcartgrad
12034       call zerograd
12035       aincr=2.0D-5
12036       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12037       nf=0
12038       icall=0
12039       call geom_to_var(nvar,x)
12040       if (.not.split_ene) then
12041         call etotal(energia)
12042         etot=energia(0)
12043 !el        call enerprint(energia)
12044         call flush(iout)
12045         write (iout,*) "enter cartgrad"
12046         call flush(iout)
12047         call cartgrad
12048         write (iout,*) "exit cartgrad"
12049         call flush(iout)
12050         icall =1
12051         do i=1,nres
12052           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12053         enddo
12054         do j=1,3
12055           grad_s(j,0)=gcart(j,0)
12056         enddo
12057         do i=1,nres
12058           do j=1,3
12059             grad_s(j,i)=gcart(j,i)
12060 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12061             grad_s(j+3,i)=gxcart(j,i)
12062           enddo
12063         enddo
12064       else
12065 !- split gradient check
12066         call zerograd
12067         call etotal_long(energia)
12068 !el        call enerprint(energia)
12069         call flush(iout)
12070         write (iout,*) "enter cartgrad"
12071         call flush(iout)
12072         call cartgrad
12073         write (iout,*) "exit cartgrad"
12074         call flush(iout)
12075         icall =1
12076         write (iout,*) "longrange grad"
12077         do i=1,nres
12078           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12079           (gxcart(j,i),j=1,3)
12080         enddo
12081         do j=1,3
12082           grad_s(j,0)=gcart(j,0)
12083         enddo
12084         do i=1,nres
12085           do j=1,3
12086             grad_s(j,i)=gcart(j,i)
12087             grad_s(j+3,i)=gxcart(j,i)
12088           enddo
12089         enddo
12090         call zerograd
12091         call etotal_short(energia)
12092 !el        call enerprint(energia)
12093         call flush(iout)
12094         write (iout,*) "enter cartgrad"
12095         call flush(iout)
12096         call cartgrad
12097         write (iout,*) "exit cartgrad"
12098         call flush(iout)
12099         icall =1
12100         write (iout,*) "shortrange grad"
12101         do i=1,nres
12102           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12103           (gxcart(j,i),j=1,3)
12104         enddo
12105         do j=1,3
12106           grad_s1(j,0)=gcart(j,0)
12107         enddo
12108         do i=1,nres
12109           do j=1,3
12110             grad_s1(j,i)=gcart(j,i)
12111             grad_s1(j+3,i)=gxcart(j,i)
12112           enddo
12113         enddo
12114       endif
12115       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12116       do i=0,nres
12117         do j=1,3
12118         xx(j)=c(j,i+nres)
12119         ddc(j)=dc(j,i)
12120         ddx(j)=dc(j,i+nres)
12121           do k=1,3
12122             dcnorm_safe(k)=dc_norm(k,i)
12123             dxnorm_safe(k)=dc_norm(k,i+nres)
12124           enddo
12125         enddo
12126       do j=1,3
12127         dc(j,i)=ddc(j)+aincr
12128           call chainbuild_cart
12129 #ifdef MPI
12130 ! Broadcast the order to compute internal coordinates to the slaves.
12131 !          if (nfgtasks.gt.1)
12132 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12133 #endif
12134 !          call int_from_cart1(.false.)
12135           if (.not.split_ene) then
12136             call etotal(energia1)
12137             etot1=energia1(0)
12138 !            call enerprint(energia1)
12139           else
12140 !- split gradient
12141             call etotal_long(energia1)
12142             etot11=energia1(0)
12143             call etotal_short(energia1)
12144             etot12=energia1(0)
12145 !            write (iout,*) "etot11",etot11," etot12",etot12
12146           endif
12147 !- end split gradient
12148 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12149         dc(j,i)=ddc(j)-aincr
12150           call chainbuild_cart
12151 !          call int_from_cart1(.false.)
12152           if (.not.split_ene) then
12153             call etotal(energia1)
12154             etot2=energia1(0)
12155           ggg(j)=(etot1-etot2)/(2*aincr)
12156           else
12157 !- split gradient
12158             call etotal_long(energia1)
12159             etot21=energia1(0)
12160           ggg(j)=(etot11-etot21)/(2*aincr)
12161             call etotal_short(energia1)
12162             etot22=energia1(0)
12163           ggg1(j)=(etot12-etot22)/(2*aincr)
12164 !- end split gradient
12165 !            write (iout,*) "etot21",etot21," etot22",etot22
12166           endif
12167 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12168         dc(j,i)=ddc(j)
12169           call chainbuild_cart
12170         enddo
12171       do j=1,3
12172         dc(j,i+nres)=ddx(j)+aincr
12173           call chainbuild_cart
12174 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12175 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12176 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12177 !          write (iout,*) "dxnormnorm",dsqrt(
12178 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12179 !          write (iout,*) "dxnormnormsafe",dsqrt(
12180 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12181 !          write (iout,*)
12182           if (.not.split_ene) then
12183             call etotal(energia1)
12184             etot1=energia1(0)
12185           else
12186 !- split gradient
12187             call etotal_long(energia1)
12188             etot11=energia1(0)
12189             call etotal_short(energia1)
12190             etot12=energia1(0)
12191           endif
12192 !- end split gradient
12193 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12194         dc(j,i+nres)=ddx(j)-aincr
12195           call chainbuild_cart
12196 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12197 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12198 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12199 !          write (iout,*)
12200 !          write (iout,*) "dxnormnorm",dsqrt(
12201 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12202 !          write (iout,*) "dxnormnormsafe",dsqrt(
12203 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12204           if (.not.split_ene) then
12205             call etotal(energia1)
12206             etot2=energia1(0)
12207           ggg(j+3)=(etot1-etot2)/(2*aincr)
12208           else
12209 !- split gradient
12210             call etotal_long(energia1)
12211             etot21=energia1(0)
12212           ggg(j+3)=(etot11-etot21)/(2*aincr)
12213             call etotal_short(energia1)
12214             etot22=energia1(0)
12215           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12216 !- end split gradient
12217           endif
12218 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12219         dc(j,i+nres)=ddx(j)
12220           call chainbuild_cart
12221         enddo
12222       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12223          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12224         if (split_ene) then
12225           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12226          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12227          k=1,6)
12228          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12229          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12230          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12231         endif
12232       enddo
12233       return
12234       end subroutine check_ecartint
12235 #endif
12236 !-----------------------------------------------------------------------------
12237       subroutine check_eint
12238 ! Check the gradient of energy in internal coordinates.
12239 !      implicit real*8 (a-h,o-z)
12240 !      include 'DIMENSIONS'
12241 !      include 'COMMON.CHAIN'
12242 !      include 'COMMON.DERIV'
12243 !      include 'COMMON.IOUNITS'
12244 !      include 'COMMON.VAR'
12245 !      include 'COMMON.GEO'
12246       use comm_srutu
12247 !el      integer :: icall
12248 !el      common /srutu/ icall
12249       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12250       integer :: uiparm(1)
12251       real(kind=8) :: urparm(1)
12252       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12253       character(len=6) :: key
12254 !EL      external fdum
12255       integer :: i,ii,nf
12256       real(kind=8) :: xi,aincr,etot,etot1,etot2
12257       call zerograd
12258       aincr=1.0D-7
12259       print '(a)','Calling CHECK_INT.'
12260       nf=0
12261       nfl=0
12262       icg=1
12263       call geom_to_var(nvar,x)
12264       call var_to_geom(nvar,x)
12265       call chainbuild
12266       icall=1
12267 !      print *,'ICG=',ICG
12268       call etotal(energia)
12269       etot = energia(0)
12270 !el      call enerprint(energia)
12271 !      print *,'ICG=',ICG
12272 #ifdef MPL
12273       if (MyID.ne.BossID) then
12274         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12275         nf=x(nvar+1)
12276         nfl=x(nvar+2)
12277         icg=x(nvar+3)
12278       endif
12279 #endif
12280       nf=1
12281       nfl=3
12282 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12283       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12284 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12285       icall=1
12286       do i=1,nvar
12287         xi=x(i)
12288         x(i)=xi-0.5D0*aincr
12289         call var_to_geom(nvar,x)
12290         call chainbuild
12291         call etotal(energia1)
12292         etot1=energia1(0)
12293         x(i)=xi+0.5D0*aincr
12294         call var_to_geom(nvar,x)
12295         call chainbuild
12296         call etotal(energia2)
12297         etot2=energia2(0)
12298         gg(i)=(etot2-etot1)/aincr
12299         write (iout,*) i,etot1,etot2
12300         x(i)=xi
12301       enddo
12302       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12303           '     RelDiff*100% '
12304       do i=1,nvar
12305         if (i.le.nphi) then
12306           ii=i
12307           key = ' phi'
12308         else if (i.le.nphi+ntheta) then
12309           ii=i-nphi
12310           key=' theta'
12311         else if (i.le.nphi+ntheta+nside) then
12312            ii=i-(nphi+ntheta)
12313            key=' alpha'
12314         else
12315            ii=i-(nphi+ntheta+nside)
12316            key=' omega'
12317         endif
12318         write (iout,'(i3,a,i3,3(1pd16.6))') &
12319        i,key,ii,gg(i),gana(i),&
12320        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12321       enddo
12322       return
12323       end subroutine check_eint
12324 !-----------------------------------------------------------------------------
12325 ! econstr_local.F
12326 !-----------------------------------------------------------------------------
12327       subroutine Econstr_back
12328 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12329 !      implicit real*8 (a-h,o-z)
12330 !      include 'DIMENSIONS'
12331 !      include 'COMMON.CONTROL'
12332 !      include 'COMMON.VAR'
12333 !      include 'COMMON.MD'
12334       use MD_data
12335 !#ifndef LANG0
12336 !      include 'COMMON.LANGEVIN'
12337 !#else
12338 !      include 'COMMON.LANGEVIN.lang0'
12339 !#endif
12340 !      include 'COMMON.CHAIN'
12341 !      include 'COMMON.DERIV'
12342 !      include 'COMMON.GEO'
12343 !      include 'COMMON.LOCAL'
12344 !      include 'COMMON.INTERACT'
12345 !      include 'COMMON.IOUNITS'
12346 !      include 'COMMON.NAMES'
12347 !      include 'COMMON.TIME1'
12348       integer :: i,j,ii,k
12349       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12350
12351       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12352       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12353       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12354
12355       Uconst_back=0.0d0
12356       do i=1,nres
12357         dutheta(i)=0.0d0
12358         dugamma(i)=0.0d0
12359         do j=1,3
12360           duscdiff(j,i)=0.0d0
12361           duscdiffx(j,i)=0.0d0
12362         enddo
12363       enddo
12364       do i=1,nfrag_back
12365         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12366 !
12367 ! Deviations from theta angles
12368 !
12369         utheta_i=0.0d0
12370         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12371           dtheta_i=theta(j)-thetaref(j)
12372           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12373           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12374         enddo
12375         utheta(i)=utheta_i/(ii-1)
12376 !
12377 ! Deviations from gamma angles
12378 !
12379         ugamma_i=0.0d0
12380         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12381           dgamma_i=pinorm(phi(j)-phiref(j))
12382 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12383           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12384           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12385 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12386         enddo
12387         ugamma(i)=ugamma_i/(ii-2)
12388 !
12389 ! Deviations from local SC geometry
12390 !
12391         uscdiff(i)=0.0d0
12392         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12393           dxx=xxtab(j)-xxref(j)
12394           dyy=yytab(j)-yyref(j)
12395           dzz=zztab(j)-zzref(j)
12396           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12397           do k=1,3
12398             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12399              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12400              (ii-1)
12401             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12402              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12403              (ii-1)
12404             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12405            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12406             /(ii-1)
12407           enddo
12408 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12409 !     &      xxref(j),yyref(j),zzref(j)
12410         enddo
12411         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12412 !        write (iout,*) i," uscdiff",uscdiff(i)
12413 !
12414 ! Put together deviations from local geometry
12415 !
12416         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12417           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12418 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12419 !     &   " uconst_back",uconst_back
12420         utheta(i)=dsqrt(utheta(i))
12421         ugamma(i)=dsqrt(ugamma(i))
12422         uscdiff(i)=dsqrt(uscdiff(i))
12423       enddo
12424       return
12425       end subroutine Econstr_back
12426 !-----------------------------------------------------------------------------
12427 ! energy_p_new-sep_barrier.F
12428 !-----------------------------------------------------------------------------
12429       real(kind=8) function sscale(r)
12430 !      include "COMMON.SPLITELE"
12431       real(kind=8) :: r,gamm
12432       if(r.lt.r_cut-rlamb) then
12433         sscale=1.0d0
12434       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12435         gamm=(r-(r_cut-rlamb))/rlamb
12436         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12437       else
12438         sscale=0d0
12439       endif
12440       return
12441       end function sscale
12442       real(kind=8) function sscale_grad(r)
12443 !      include "COMMON.SPLITELE"
12444       real(kind=8) :: r,gamm
12445       if(r.lt.r_cut-rlamb) then
12446         sscale_grad=0.0d0
12447       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12448         gamm=(r-(r_cut-rlamb))/rlamb
12449         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12450       else
12451         sscale_grad=0d0
12452       endif
12453       return
12454       end function sscale_grad
12455
12456 !!!!!!!!!! PBCSCALE
12457       real(kind=8) function sscale_ele(r)
12458 !      include "COMMON.SPLITELE"
12459       real(kind=8) :: r,gamm
12460       if(r.lt.r_cut_ele-rlamb_ele) then
12461         sscale_ele=1.0d0
12462       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12463         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12464         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12465       else
12466         sscale_ele=0d0
12467       endif
12468       return
12469       end function sscale_ele
12470
12471       real(kind=8)  function sscagrad_ele(r)
12472       real(kind=8) :: r,gamm
12473 !      include "COMMON.SPLITELE"
12474       if(r.lt.r_cut_ele-rlamb_ele) then
12475         sscagrad_ele=0.0d0
12476       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12477         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12478         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12479       else
12480         sscagrad_ele=0.0d0
12481       endif
12482       return
12483       end function sscagrad_ele
12484       real(kind=8) function sscalelip(r)
12485       real(kind=8) r,gamm
12486         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12487       return
12488       end function sscalelip
12489 !C-----------------------------------------------------------------------
12490       real(kind=8) function sscagradlip(r)
12491       real(kind=8) r,gamm
12492         sscagradlip=r*(6.0d0*r-6.0d0)
12493       return
12494       end function sscagradlip
12495
12496 !!!!!!!!!!!!!!!
12497 !-----------------------------------------------------------------------------
12498       subroutine elj_long(evdw)
12499 !
12500 ! This subroutine calculates the interaction energy of nonbonded side chains
12501 ! assuming the LJ potential of interaction.
12502 !
12503 !      implicit real*8 (a-h,o-z)
12504 !      include 'DIMENSIONS'
12505 !      include 'COMMON.GEO'
12506 !      include 'COMMON.VAR'
12507 !      include 'COMMON.LOCAL'
12508 !      include 'COMMON.CHAIN'
12509 !      include 'COMMON.DERIV'
12510 !      include 'COMMON.INTERACT'
12511 !      include 'COMMON.TORSION'
12512 !      include 'COMMON.SBRIDGE'
12513 !      include 'COMMON.NAMES'
12514 !      include 'COMMON.IOUNITS'
12515 !      include 'COMMON.CONTACTS'
12516       real(kind=8),parameter :: accur=1.0d-10
12517       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12518 !el local variables
12519       integer :: i,iint,j,k,itypi,itypi1,itypj
12520       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12521       real(kind=8) :: e1,e2,evdwij,evdw
12522 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12523       evdw=0.0D0
12524       do i=iatsc_s,iatsc_e
12525         itypi=itype(i,1)
12526         if (itypi.eq.ntyp1) cycle
12527         itypi1=itype(i+1,1)
12528         xi=c(1,nres+i)
12529         yi=c(2,nres+i)
12530         zi=c(3,nres+i)
12531 !
12532 ! Calculate SC interaction energy.
12533 !
12534         do iint=1,nint_gr(i)
12535 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12536 !d   &                  'iend=',iend(i,iint)
12537           do j=istart(i,iint),iend(i,iint)
12538             itypj=itype(j,1)
12539             if (itypj.eq.ntyp1) cycle
12540             xj=c(1,nres+j)-xi
12541             yj=c(2,nres+j)-yi
12542             zj=c(3,nres+j)-zi
12543             rij=xj*xj+yj*yj+zj*zj
12544             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12545             if (sss.lt.1.0d0) then
12546               rrij=1.0D0/rij
12547               eps0ij=eps(itypi,itypj)
12548               fac=rrij**expon2
12549               e1=fac*fac*aa_aq(itypi,itypj)
12550               e2=fac*bb_aq(itypi,itypj)
12551               evdwij=e1+e2
12552               evdw=evdw+(1.0d0-sss)*evdwij
12553 !
12554 ! Calculate the components of the gradient in DC and X
12555 !
12556               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12557               gg(1)=xj*fac
12558               gg(2)=yj*fac
12559               gg(3)=zj*fac
12560               do k=1,3
12561                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12562                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12563                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12564                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12565               enddo
12566             endif
12567           enddo      ! j
12568         enddo        ! iint
12569       enddo          ! i
12570       do i=1,nct
12571         do j=1,3
12572           gvdwc(j,i)=expon*gvdwc(j,i)
12573           gvdwx(j,i)=expon*gvdwx(j,i)
12574         enddo
12575       enddo
12576 !******************************************************************************
12577 !
12578 !                              N O T E !!!
12579 !
12580 ! To save time, the factor of EXPON has been extracted from ALL components
12581 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12582 ! use!
12583 !
12584 !******************************************************************************
12585       return
12586       end subroutine elj_long
12587 !-----------------------------------------------------------------------------
12588       subroutine elj_short(evdw)
12589 !
12590 ! This subroutine calculates the interaction energy of nonbonded side chains
12591 ! assuming the LJ potential of interaction.
12592 !
12593 !      implicit real*8 (a-h,o-z)
12594 !      include 'DIMENSIONS'
12595 !      include 'COMMON.GEO'
12596 !      include 'COMMON.VAR'
12597 !      include 'COMMON.LOCAL'
12598 !      include 'COMMON.CHAIN'
12599 !      include 'COMMON.DERIV'
12600 !      include 'COMMON.INTERACT'
12601 !      include 'COMMON.TORSION'
12602 !      include 'COMMON.SBRIDGE'
12603 !      include 'COMMON.NAMES'
12604 !      include 'COMMON.IOUNITS'
12605 !      include 'COMMON.CONTACTS'
12606       real(kind=8),parameter :: accur=1.0d-10
12607       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12608 !el local variables
12609       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12610       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12611       real(kind=8) :: e1,e2,evdwij,evdw
12612 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12613       evdw=0.0D0
12614       do i=iatsc_s,iatsc_e
12615         itypi=itype(i,1)
12616         if (itypi.eq.ntyp1) cycle
12617         itypi1=itype(i+1,1)
12618         xi=c(1,nres+i)
12619         yi=c(2,nres+i)
12620         zi=c(3,nres+i)
12621 ! Change 12/1/95
12622         num_conti=0
12623 !
12624 ! Calculate SC interaction energy.
12625 !
12626         do iint=1,nint_gr(i)
12627 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12628 !d   &                  'iend=',iend(i,iint)
12629           do j=istart(i,iint),iend(i,iint)
12630             itypj=itype(j,1)
12631             if (itypj.eq.ntyp1) cycle
12632             xj=c(1,nres+j)-xi
12633             yj=c(2,nres+j)-yi
12634             zj=c(3,nres+j)-zi
12635 ! Change 12/1/95 to calculate four-body interactions
12636             rij=xj*xj+yj*yj+zj*zj
12637             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12638             if (sss.gt.0.0d0) then
12639               rrij=1.0D0/rij
12640               eps0ij=eps(itypi,itypj)
12641               fac=rrij**expon2
12642               e1=fac*fac*aa_aq(itypi,itypj)
12643               e2=fac*bb_aq(itypi,itypj)
12644               evdwij=e1+e2
12645               evdw=evdw+sss*evdwij
12646 !
12647 ! Calculate the components of the gradient in DC and X
12648 !
12649               fac=-rrij*(e1+evdwij)*sss
12650               gg(1)=xj*fac
12651               gg(2)=yj*fac
12652               gg(3)=zj*fac
12653               do k=1,3
12654                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12655                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12656                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12657                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12658               enddo
12659             endif
12660           enddo      ! j
12661         enddo        ! iint
12662       enddo          ! i
12663       do i=1,nct
12664         do j=1,3
12665           gvdwc(j,i)=expon*gvdwc(j,i)
12666           gvdwx(j,i)=expon*gvdwx(j,i)
12667         enddo
12668       enddo
12669 !******************************************************************************
12670 !
12671 !                              N O T E !!!
12672 !
12673 ! To save time, the factor of EXPON has been extracted from ALL components
12674 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12675 ! use!
12676 !
12677 !******************************************************************************
12678       return
12679       end subroutine elj_short
12680 !-----------------------------------------------------------------------------
12681       subroutine eljk_long(evdw)
12682 !
12683 ! This subroutine calculates the interaction energy of nonbonded side chains
12684 ! assuming the LJK potential of interaction.
12685 !
12686 !      implicit real*8 (a-h,o-z)
12687 !      include 'DIMENSIONS'
12688 !      include 'COMMON.GEO'
12689 !      include 'COMMON.VAR'
12690 !      include 'COMMON.LOCAL'
12691 !      include 'COMMON.CHAIN'
12692 !      include 'COMMON.DERIV'
12693 !      include 'COMMON.INTERACT'
12694 !      include 'COMMON.IOUNITS'
12695 !      include 'COMMON.NAMES'
12696       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12697       logical :: scheck
12698 !el local variables
12699       integer :: i,iint,j,k,itypi,itypi1,itypj
12700       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12701                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12702 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12703       evdw=0.0D0
12704       do i=iatsc_s,iatsc_e
12705         itypi=itype(i,1)
12706         if (itypi.eq.ntyp1) cycle
12707         itypi1=itype(i+1,1)
12708         xi=c(1,nres+i)
12709         yi=c(2,nres+i)
12710         zi=c(3,nres+i)
12711 !
12712 ! Calculate SC interaction energy.
12713 !
12714         do iint=1,nint_gr(i)
12715           do j=istart(i,iint),iend(i,iint)
12716             itypj=itype(j,1)
12717             if (itypj.eq.ntyp1) cycle
12718             xj=c(1,nres+j)-xi
12719             yj=c(2,nres+j)-yi
12720             zj=c(3,nres+j)-zi
12721             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12722             fac_augm=rrij**expon
12723             e_augm=augm(itypi,itypj)*fac_augm
12724             r_inv_ij=dsqrt(rrij)
12725             rij=1.0D0/r_inv_ij
12726             sss=sscale(rij/sigma(itypi,itypj))
12727             if (sss.lt.1.0d0) then
12728               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12729               fac=r_shift_inv**expon
12730               e1=fac*fac*aa_aq(itypi,itypj)
12731               e2=fac*bb_aq(itypi,itypj)
12732               evdwij=e_augm+e1+e2
12733 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12734 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12735 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12736 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12737 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12738 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12739 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12740               evdw=evdw+(1.0d0-sss)*evdwij
12741 !
12742 ! Calculate the components of the gradient in DC and X
12743 !
12744               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12745               fac=fac*(1.0d0-sss)
12746               gg(1)=xj*fac
12747               gg(2)=yj*fac
12748               gg(3)=zj*fac
12749               do k=1,3
12750                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12751                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12752                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12753                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12754               enddo
12755             endif
12756           enddo      ! j
12757         enddo        ! iint
12758       enddo          ! i
12759       do i=1,nct
12760         do j=1,3
12761           gvdwc(j,i)=expon*gvdwc(j,i)
12762           gvdwx(j,i)=expon*gvdwx(j,i)
12763         enddo
12764       enddo
12765       return
12766       end subroutine eljk_long
12767 !-----------------------------------------------------------------------------
12768       subroutine eljk_short(evdw)
12769 !
12770 ! This subroutine calculates the interaction energy of nonbonded side chains
12771 ! assuming the LJK potential of interaction.
12772 !
12773 !      implicit real*8 (a-h,o-z)
12774 !      include 'DIMENSIONS'
12775 !      include 'COMMON.GEO'
12776 !      include 'COMMON.VAR'
12777 !      include 'COMMON.LOCAL'
12778 !      include 'COMMON.CHAIN'
12779 !      include 'COMMON.DERIV'
12780 !      include 'COMMON.INTERACT'
12781 !      include 'COMMON.IOUNITS'
12782 !      include 'COMMON.NAMES'
12783       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12784       logical :: scheck
12785 !el local variables
12786       integer :: i,iint,j,k,itypi,itypi1,itypj
12787       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12788                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12789 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12790       evdw=0.0D0
12791       do i=iatsc_s,iatsc_e
12792         itypi=itype(i,1)
12793         if (itypi.eq.ntyp1) cycle
12794         itypi1=itype(i+1,1)
12795         xi=c(1,nres+i)
12796         yi=c(2,nres+i)
12797         zi=c(3,nres+i)
12798 !
12799 ! Calculate SC interaction energy.
12800 !
12801         do iint=1,nint_gr(i)
12802           do j=istart(i,iint),iend(i,iint)
12803             itypj=itype(j,1)
12804             if (itypj.eq.ntyp1) cycle
12805             xj=c(1,nres+j)-xi
12806             yj=c(2,nres+j)-yi
12807             zj=c(3,nres+j)-zi
12808             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12809             fac_augm=rrij**expon
12810             e_augm=augm(itypi,itypj)*fac_augm
12811             r_inv_ij=dsqrt(rrij)
12812             rij=1.0D0/r_inv_ij
12813             sss=sscale(rij/sigma(itypi,itypj))
12814             if (sss.gt.0.0d0) then
12815               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12816               fac=r_shift_inv**expon
12817               e1=fac*fac*aa_aq(itypi,itypj)
12818               e2=fac*bb_aq(itypi,itypj)
12819               evdwij=e_augm+e1+e2
12820 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12821 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12822 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12823 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12824 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12825 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12826 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12827               evdw=evdw+sss*evdwij
12828 !
12829 ! Calculate the components of the gradient in DC and X
12830 !
12831               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12832               fac=fac*sss
12833               gg(1)=xj*fac
12834               gg(2)=yj*fac
12835               gg(3)=zj*fac
12836               do k=1,3
12837                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12838                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12839                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12840                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12841               enddo
12842             endif
12843           enddo      ! j
12844         enddo        ! iint
12845       enddo          ! i
12846       do i=1,nct
12847         do j=1,3
12848           gvdwc(j,i)=expon*gvdwc(j,i)
12849           gvdwx(j,i)=expon*gvdwx(j,i)
12850         enddo
12851       enddo
12852       return
12853       end subroutine eljk_short
12854 !-----------------------------------------------------------------------------
12855       subroutine ebp_long(evdw)
12856 !
12857 ! This subroutine calculates the interaction energy of nonbonded side chains
12858 ! assuming the Berne-Pechukas potential of interaction.
12859 !
12860       use calc_data
12861 !      implicit real*8 (a-h,o-z)
12862 !      include 'DIMENSIONS'
12863 !      include 'COMMON.GEO'
12864 !      include 'COMMON.VAR'
12865 !      include 'COMMON.LOCAL'
12866 !      include 'COMMON.CHAIN'
12867 !      include 'COMMON.DERIV'
12868 !      include 'COMMON.NAMES'
12869 !      include 'COMMON.INTERACT'
12870 !      include 'COMMON.IOUNITS'
12871 !      include 'COMMON.CALC'
12872       use comm_srutu
12873 !el      integer :: icall
12874 !el      common /srutu/ icall
12875 !     double precision rrsave(maxdim)
12876       logical :: lprn
12877 !el local variables
12878       integer :: iint,itypi,itypi1,itypj
12879       real(kind=8) :: rrij,xi,yi,zi,fac
12880       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12881       evdw=0.0D0
12882 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12883       evdw=0.0D0
12884 !     if (icall.eq.0) then
12885 !       lprn=.true.
12886 !     else
12887         lprn=.false.
12888 !     endif
12889 !el      ind=0
12890       do i=iatsc_s,iatsc_e
12891         itypi=itype(i,1)
12892         if (itypi.eq.ntyp1) cycle
12893         itypi1=itype(i+1,1)
12894         xi=c(1,nres+i)
12895         yi=c(2,nres+i)
12896         zi=c(3,nres+i)
12897         dxi=dc_norm(1,nres+i)
12898         dyi=dc_norm(2,nres+i)
12899         dzi=dc_norm(3,nres+i)
12900 !        dsci_inv=dsc_inv(itypi)
12901         dsci_inv=vbld_inv(i+nres)
12902 !
12903 ! Calculate SC interaction energy.
12904 !
12905         do iint=1,nint_gr(i)
12906           do j=istart(i,iint),iend(i,iint)
12907 !el            ind=ind+1
12908             itypj=itype(j,1)
12909             if (itypj.eq.ntyp1) cycle
12910 !            dscj_inv=dsc_inv(itypj)
12911             dscj_inv=vbld_inv(j+nres)
12912             chi1=chi(itypi,itypj)
12913             chi2=chi(itypj,itypi)
12914             chi12=chi1*chi2
12915             chip1=chip(itypi)
12916             chip2=chip(itypj)
12917             chip12=chip1*chip2
12918             alf1=alp(itypi)
12919             alf2=alp(itypj)
12920             alf12=0.5D0*(alf1+alf2)
12921             xj=c(1,nres+j)-xi
12922             yj=c(2,nres+j)-yi
12923             zj=c(3,nres+j)-zi
12924             dxj=dc_norm(1,nres+j)
12925             dyj=dc_norm(2,nres+j)
12926             dzj=dc_norm(3,nres+j)
12927             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12928             rij=dsqrt(rrij)
12929             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12930
12931             if (sss.lt.1.0d0) then
12932
12933 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12934               call sc_angular
12935 ! Calculate whole angle-dependent part of epsilon and contributions
12936 ! to its derivatives
12937               fac=(rrij*sigsq)**expon2
12938               e1=fac*fac*aa_aq(itypi,itypj)
12939               e2=fac*bb_aq(itypi,itypj)
12940               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12941               eps2der=evdwij*eps3rt
12942               eps3der=evdwij*eps2rt
12943               evdwij=evdwij*eps2rt*eps3rt
12944               evdw=evdw+evdwij*(1.0d0-sss)
12945               if (lprn) then
12946               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12947               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12948 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12949 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12950 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12951 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12952 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12953 !d     &          evdwij
12954               endif
12955 ! Calculate gradient components.
12956               e1=e1*eps1*eps2rt**2*eps3rt**2
12957               fac=-expon*(e1+evdwij)
12958               sigder=fac/sigsq
12959               fac=rrij*fac
12960 ! Calculate radial part of the gradient
12961               gg(1)=xj*fac
12962               gg(2)=yj*fac
12963               gg(3)=zj*fac
12964 ! Calculate the angular part of the gradient and sum add the contributions
12965 ! to the appropriate components of the Cartesian gradient.
12966               call sc_grad_scale(1.0d0-sss)
12967             endif
12968           enddo      ! j
12969         enddo        ! iint
12970       enddo          ! i
12971 !     stop
12972       return
12973       end subroutine ebp_long
12974 !-----------------------------------------------------------------------------
12975       subroutine ebp_short(evdw)
12976 !
12977 ! This subroutine calculates the interaction energy of nonbonded side chains
12978 ! assuming the Berne-Pechukas potential of interaction.
12979 !
12980       use calc_data
12981 !      implicit real*8 (a-h,o-z)
12982 !      include 'DIMENSIONS'
12983 !      include 'COMMON.GEO'
12984 !      include 'COMMON.VAR'
12985 !      include 'COMMON.LOCAL'
12986 !      include 'COMMON.CHAIN'
12987 !      include 'COMMON.DERIV'
12988 !      include 'COMMON.NAMES'
12989 !      include 'COMMON.INTERACT'
12990 !      include 'COMMON.IOUNITS'
12991 !      include 'COMMON.CALC'
12992       use comm_srutu
12993 !el      integer :: icall
12994 !el      common /srutu/ icall
12995 !     double precision rrsave(maxdim)
12996       logical :: lprn
12997 !el local variables
12998       integer :: iint,itypi,itypi1,itypj
12999       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13000       real(kind=8) :: sss,e1,e2,evdw
13001       evdw=0.0D0
13002 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13003       evdw=0.0D0
13004 !     if (icall.eq.0) then
13005 !       lprn=.true.
13006 !     else
13007         lprn=.false.
13008 !     endif
13009 !el      ind=0
13010       do i=iatsc_s,iatsc_e
13011         itypi=itype(i,1)
13012         if (itypi.eq.ntyp1) cycle
13013         itypi1=itype(i+1,1)
13014         xi=c(1,nres+i)
13015         yi=c(2,nres+i)
13016         zi=c(3,nres+i)
13017         dxi=dc_norm(1,nres+i)
13018         dyi=dc_norm(2,nres+i)
13019         dzi=dc_norm(3,nres+i)
13020 !        dsci_inv=dsc_inv(itypi)
13021         dsci_inv=vbld_inv(i+nres)
13022 !
13023 ! Calculate SC interaction energy.
13024 !
13025         do iint=1,nint_gr(i)
13026           do j=istart(i,iint),iend(i,iint)
13027 !el            ind=ind+1
13028             itypj=itype(j,1)
13029             if (itypj.eq.ntyp1) cycle
13030 !            dscj_inv=dsc_inv(itypj)
13031             dscj_inv=vbld_inv(j+nres)
13032             chi1=chi(itypi,itypj)
13033             chi2=chi(itypj,itypi)
13034             chi12=chi1*chi2
13035             chip1=chip(itypi)
13036             chip2=chip(itypj)
13037             chip12=chip1*chip2
13038             alf1=alp(itypi)
13039             alf2=alp(itypj)
13040             alf12=0.5D0*(alf1+alf2)
13041             xj=c(1,nres+j)-xi
13042             yj=c(2,nres+j)-yi
13043             zj=c(3,nres+j)-zi
13044             dxj=dc_norm(1,nres+j)
13045             dyj=dc_norm(2,nres+j)
13046             dzj=dc_norm(3,nres+j)
13047             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13048             rij=dsqrt(rrij)
13049             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13050
13051             if (sss.gt.0.0d0) then
13052
13053 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13054               call sc_angular
13055 ! Calculate whole angle-dependent part of epsilon and contributions
13056 ! to its derivatives
13057               fac=(rrij*sigsq)**expon2
13058               e1=fac*fac*aa_aq(itypi,itypj)
13059               e2=fac*bb_aq(itypi,itypj)
13060               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13061               eps2der=evdwij*eps3rt
13062               eps3der=evdwij*eps2rt
13063               evdwij=evdwij*eps2rt*eps3rt
13064               evdw=evdw+evdwij*sss
13065               if (lprn) then
13066               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13067               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13068 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13069 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13070 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13071 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13072 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13073 !d     &          evdwij
13074               endif
13075 ! Calculate gradient components.
13076               e1=e1*eps1*eps2rt**2*eps3rt**2
13077               fac=-expon*(e1+evdwij)
13078               sigder=fac/sigsq
13079               fac=rrij*fac
13080 ! Calculate radial part of the gradient
13081               gg(1)=xj*fac
13082               gg(2)=yj*fac
13083               gg(3)=zj*fac
13084 ! Calculate the angular part of the gradient and sum add the contributions
13085 ! to the appropriate components of the Cartesian gradient.
13086               call sc_grad_scale(sss)
13087             endif
13088           enddo      ! j
13089         enddo        ! iint
13090       enddo          ! i
13091 !     stop
13092       return
13093       end subroutine ebp_short
13094 !-----------------------------------------------------------------------------
13095       subroutine egb_long(evdw)
13096 !
13097 ! This subroutine calculates the interaction energy of nonbonded side chains
13098 ! assuming the Gay-Berne potential of interaction.
13099 !
13100       use calc_data
13101 !      implicit real*8 (a-h,o-z)
13102 !      include 'DIMENSIONS'
13103 !      include 'COMMON.GEO'
13104 !      include 'COMMON.VAR'
13105 !      include 'COMMON.LOCAL'
13106 !      include 'COMMON.CHAIN'
13107 !      include 'COMMON.DERIV'
13108 !      include 'COMMON.NAMES'
13109 !      include 'COMMON.INTERACT'
13110 !      include 'COMMON.IOUNITS'
13111 !      include 'COMMON.CALC'
13112 !      include 'COMMON.CONTROL'
13113       logical :: lprn
13114 !el local variables
13115       integer :: iint,itypi,itypi1,itypj,subchap
13116       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13117       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13118       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13119                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13120                     ssgradlipi,ssgradlipj
13121
13122
13123       evdw=0.0D0
13124 !cccc      energy_dec=.false.
13125 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13126       evdw=0.0D0
13127       lprn=.false.
13128 !     if (icall.eq.0) lprn=.false.
13129 !el      ind=0
13130       do i=iatsc_s,iatsc_e
13131         itypi=itype(i,1)
13132         if (itypi.eq.ntyp1) cycle
13133         itypi1=itype(i+1,1)
13134         xi=c(1,nres+i)
13135         yi=c(2,nres+i)
13136         zi=c(3,nres+i)
13137           xi=mod(xi,boxxsize)
13138           if (xi.lt.0) xi=xi+boxxsize
13139           yi=mod(yi,boxysize)
13140           if (yi.lt.0) yi=yi+boxysize
13141           zi=mod(zi,boxzsize)
13142           if (zi.lt.0) zi=zi+boxzsize
13143        if ((zi.gt.bordlipbot)    &
13144         .and.(zi.lt.bordliptop)) then
13145 !C the energy transfer exist
13146         if (zi.lt.buflipbot) then
13147 !C what fraction I am in
13148          fracinbuf=1.0d0-    &
13149              ((zi-bordlipbot)/lipbufthick)
13150 !C lipbufthick is thickenes of lipid buffore
13151          sslipi=sscalelip(fracinbuf)
13152          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13153         elseif (zi.gt.bufliptop) then
13154          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13155          sslipi=sscalelip(fracinbuf)
13156          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13157         else
13158          sslipi=1.0d0
13159          ssgradlipi=0.0
13160         endif
13161        else
13162          sslipi=0.0d0
13163          ssgradlipi=0.0
13164        endif
13165
13166         dxi=dc_norm(1,nres+i)
13167         dyi=dc_norm(2,nres+i)
13168         dzi=dc_norm(3,nres+i)
13169 !        dsci_inv=dsc_inv(itypi)
13170         dsci_inv=vbld_inv(i+nres)
13171 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13172 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13173 !
13174 ! Calculate SC interaction energy.
13175 !
13176         do iint=1,nint_gr(i)
13177           do j=istart(i,iint),iend(i,iint)
13178             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13179 !              call dyn_ssbond_ene(i,j,evdwij)
13180 !              evdw=evdw+evdwij
13181 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13182 !                              'evdw',i,j,evdwij,' ss'
13183 !              if (energy_dec) write (iout,*) &
13184 !                              'evdw',i,j,evdwij,' ss'
13185 !             do k=j+1,iend(i,iint)
13186 !C search over all next residues
13187 !              if (dyn_ss_mask(k)) then
13188 !C check if they are cysteins
13189 !C              write(iout,*) 'k=',k
13190
13191 !c              write(iout,*) "PRZED TRI", evdwij
13192 !               evdwij_przed_tri=evdwij
13193 !              call triple_ssbond_ene(i,j,k,evdwij)
13194 !c               if(evdwij_przed_tri.ne.evdwij) then
13195 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13196 !c               endif
13197
13198 !c              write(iout,*) "PO TRI", evdwij
13199 !C call the energy function that removes the artifical triple disulfide
13200 !C bond the soubroutine is located in ssMD.F
13201 !              evdw=evdw+evdwij
13202               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13203                             'evdw',i,j,evdwij,'tss'
13204 !              endif!dyn_ss_mask(k)
13205 !             enddo! k
13206
13207             ELSE
13208 !el            ind=ind+1
13209             itypj=itype(j,1)
13210             if (itypj.eq.ntyp1) cycle
13211 !            dscj_inv=dsc_inv(itypj)
13212             dscj_inv=vbld_inv(j+nres)
13213 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13214 !     &       1.0d0/vbld(j+nres)
13215 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13216             sig0ij=sigma(itypi,itypj)
13217             chi1=chi(itypi,itypj)
13218             chi2=chi(itypj,itypi)
13219             chi12=chi1*chi2
13220             chip1=chip(itypi)
13221             chip2=chip(itypj)
13222             chip12=chip1*chip2
13223             alf1=alp(itypi)
13224             alf2=alp(itypj)
13225             alf12=0.5D0*(alf1+alf2)
13226             xj=c(1,nres+j)
13227             yj=c(2,nres+j)
13228             zj=c(3,nres+j)
13229 ! Searching for nearest neighbour
13230           xj=mod(xj,boxxsize)
13231           if (xj.lt.0) xj=xj+boxxsize
13232           yj=mod(yj,boxysize)
13233           if (yj.lt.0) yj=yj+boxysize
13234           zj=mod(zj,boxzsize)
13235           if (zj.lt.0) zj=zj+boxzsize
13236        if ((zj.gt.bordlipbot)   &
13237       .and.(zj.lt.bordliptop)) then
13238 !C the energy transfer exist
13239         if (zj.lt.buflipbot) then
13240 !C what fraction I am in
13241          fracinbuf=1.0d0-  &
13242              ((zj-bordlipbot)/lipbufthick)
13243 !C lipbufthick is thickenes of lipid buffore
13244          sslipj=sscalelip(fracinbuf)
13245          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13246         elseif (zj.gt.bufliptop) then
13247          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13248          sslipj=sscalelip(fracinbuf)
13249          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13250         else
13251          sslipj=1.0d0
13252          ssgradlipj=0.0
13253         endif
13254        else
13255          sslipj=0.0d0
13256          ssgradlipj=0.0
13257        endif
13258       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13259        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13260       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13261        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13262
13263           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13264           xj_safe=xj
13265           yj_safe=yj
13266           zj_safe=zj
13267           subchap=0
13268           do xshift=-1,1
13269           do yshift=-1,1
13270           do zshift=-1,1
13271           xj=xj_safe+xshift*boxxsize
13272           yj=yj_safe+yshift*boxysize
13273           zj=zj_safe+zshift*boxzsize
13274           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13275           if(dist_temp.lt.dist_init) then
13276             dist_init=dist_temp
13277             xj_temp=xj
13278             yj_temp=yj
13279             zj_temp=zj
13280             subchap=1
13281           endif
13282           enddo
13283           enddo
13284           enddo
13285           if (subchap.eq.1) then
13286           xj=xj_temp-xi
13287           yj=yj_temp-yi
13288           zj=zj_temp-zi
13289           else
13290           xj=xj_safe-xi
13291           yj=yj_safe-yi
13292           zj=zj_safe-zi
13293           endif
13294
13295             dxj=dc_norm(1,nres+j)
13296             dyj=dc_norm(2,nres+j)
13297             dzj=dc_norm(3,nres+j)
13298             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13299             rij=dsqrt(rrij)
13300             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13301             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13302             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13303             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13304             if (sss_ele_cut.le.0.0) cycle
13305             if (sss.lt.1.0d0) then
13306
13307 ! Calculate angle-dependent terms of energy and contributions to their
13308 ! derivatives.
13309               call sc_angular
13310               sigsq=1.0D0/sigsq
13311               sig=sig0ij*dsqrt(sigsq)
13312               rij_shift=1.0D0/rij-sig+sig0ij
13313 ! for diagnostics; uncomment
13314 !              rij_shift=1.2*sig0ij
13315 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13316               if (rij_shift.le.0.0D0) then
13317                 evdw=1.0D20
13318 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13319 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13320 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13321                 return
13322               endif
13323               sigder=-sig*sigsq
13324 !---------------------------------------------------------------
13325               rij_shift=1.0D0/rij_shift
13326               fac=rij_shift**expon
13327               e1=fac*fac*aa
13328               e2=fac*bb
13329               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13330               eps2der=evdwij*eps3rt
13331               eps3der=evdwij*eps2rt
13332 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13333 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13334               evdwij=evdwij*eps2rt*eps3rt
13335               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13336               if (lprn) then
13337               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13338               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13339               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13340                 restyp(itypi,1),i,restyp(itypj,1),j,&
13341                 epsi,sigm,chi1,chi2,chip1,chip2,&
13342                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13343                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13344                 evdwij
13345               endif
13346
13347               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13348                               'evdw',i,j,evdwij
13349 !              if (energy_dec) write (iout,*) &
13350 !                              'evdw',i,j,evdwij,"egb_long"
13351
13352 ! Calculate gradient components.
13353               e1=e1*eps1*eps2rt**2*eps3rt**2
13354               fac=-expon*(e1+evdwij)*rij_shift
13355               sigder=fac*sigder
13356               fac=rij*fac
13357               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13358             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13359             /sigmaii(itypi,itypj))
13360 !              fac=0.0d0
13361 ! Calculate the radial part of the gradient
13362               gg(1)=xj*fac
13363               gg(2)=yj*fac
13364               gg(3)=zj*fac
13365 ! Calculate angular part of the gradient.
13366               call sc_grad_scale(1.0d0-sss)
13367             ENDIF    !mask_dyn_ss
13368             endif
13369           enddo      ! j
13370         enddo        ! iint
13371       enddo          ! i
13372 !      write (iout,*) "Number of loop steps in EGB:",ind
13373 !ccc      energy_dec=.false.
13374       return
13375       end subroutine egb_long
13376 !-----------------------------------------------------------------------------
13377       subroutine egb_short(evdw)
13378 !
13379 ! This subroutine calculates the interaction energy of nonbonded side chains
13380 ! assuming the Gay-Berne potential of interaction.
13381 !
13382       use calc_data
13383 !      implicit real*8 (a-h,o-z)
13384 !      include 'DIMENSIONS'
13385 !      include 'COMMON.GEO'
13386 !      include 'COMMON.VAR'
13387 !      include 'COMMON.LOCAL'
13388 !      include 'COMMON.CHAIN'
13389 !      include 'COMMON.DERIV'
13390 !      include 'COMMON.NAMES'
13391 !      include 'COMMON.INTERACT'
13392 !      include 'COMMON.IOUNITS'
13393 !      include 'COMMON.CALC'
13394 !      include 'COMMON.CONTROL'
13395       logical :: lprn
13396 !el local variables
13397       integer :: iint,itypi,itypi1,itypj,subchap
13398       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13399       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13400       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13401                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13402                     ssgradlipi,ssgradlipj
13403       evdw=0.0D0
13404 !cccc      energy_dec=.false.
13405 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13406       evdw=0.0D0
13407       lprn=.false.
13408 !     if (icall.eq.0) lprn=.false.
13409 !el      ind=0
13410       do i=iatsc_s,iatsc_e
13411         itypi=itype(i,1)
13412         if (itypi.eq.ntyp1) cycle
13413         itypi1=itype(i+1,1)
13414         xi=c(1,nres+i)
13415         yi=c(2,nres+i)
13416         zi=c(3,nres+i)
13417           xi=mod(xi,boxxsize)
13418           if (xi.lt.0) xi=xi+boxxsize
13419           yi=mod(yi,boxysize)
13420           if (yi.lt.0) yi=yi+boxysize
13421           zi=mod(zi,boxzsize)
13422           if (zi.lt.0) zi=zi+boxzsize
13423        if ((zi.gt.bordlipbot)    &
13424         .and.(zi.lt.bordliptop)) then
13425 !C the energy transfer exist
13426         if (zi.lt.buflipbot) then
13427 !C what fraction I am in
13428          fracinbuf=1.0d0-    &
13429              ((zi-bordlipbot)/lipbufthick)
13430 !C lipbufthick is thickenes of lipid buffore
13431          sslipi=sscalelip(fracinbuf)
13432          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13433         elseif (zi.gt.bufliptop) then
13434          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13435          sslipi=sscalelip(fracinbuf)
13436          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13437         else
13438          sslipi=1.0d0
13439          ssgradlipi=0.0
13440         endif
13441        else
13442          sslipi=0.0d0
13443          ssgradlipi=0.0
13444        endif
13445
13446         dxi=dc_norm(1,nres+i)
13447         dyi=dc_norm(2,nres+i)
13448         dzi=dc_norm(3,nres+i)
13449 !        dsci_inv=dsc_inv(itypi)
13450         dsci_inv=vbld_inv(i+nres)
13451
13452         dxi=dc_norm(1,nres+i)
13453         dyi=dc_norm(2,nres+i)
13454         dzi=dc_norm(3,nres+i)
13455 !        dsci_inv=dsc_inv(itypi)
13456         dsci_inv=vbld_inv(i+nres)
13457 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13458 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13459 !
13460 ! Calculate SC interaction energy.
13461 !
13462         do iint=1,nint_gr(i)
13463           do j=istart(i,iint),iend(i,iint)
13464             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13465               call dyn_ssbond_ene(i,j,evdwij)
13466               evdw=evdw+evdwij
13467               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13468                               'evdw',i,j,evdwij,' ss'
13469              do k=j+1,iend(i,iint)
13470 !C search over all next residues
13471               if (dyn_ss_mask(k)) then
13472 !C check if they are cysteins
13473 !C              write(iout,*) 'k=',k
13474
13475 !c              write(iout,*) "PRZED TRI", evdwij
13476 !               evdwij_przed_tri=evdwij
13477               call triple_ssbond_ene(i,j,k,evdwij)
13478 !c               if(evdwij_przed_tri.ne.evdwij) then
13479 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13480 !c               endif
13481
13482 !c              write(iout,*) "PO TRI", evdwij
13483 !C call the energy function that removes the artifical triple disulfide
13484 !C bond the soubroutine is located in ssMD.F
13485               evdw=evdw+evdwij
13486               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13487                             'evdw',i,j,evdwij,'tss'
13488               endif!dyn_ss_mask(k)
13489              enddo! k
13490
13491 !              if (energy_dec) write (iout,*) &
13492 !                              'evdw',i,j,evdwij,' ss'
13493             ELSE
13494 !el            ind=ind+1
13495             itypj=itype(j,1)
13496             if (itypj.eq.ntyp1) cycle
13497 !            dscj_inv=dsc_inv(itypj)
13498             dscj_inv=vbld_inv(j+nres)
13499 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13500 !     &       1.0d0/vbld(j+nres)
13501 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13502             sig0ij=sigma(itypi,itypj)
13503             chi1=chi(itypi,itypj)
13504             chi2=chi(itypj,itypi)
13505             chi12=chi1*chi2
13506             chip1=chip(itypi)
13507             chip2=chip(itypj)
13508             chip12=chip1*chip2
13509             alf1=alp(itypi)
13510             alf2=alp(itypj)
13511             alf12=0.5D0*(alf1+alf2)
13512 !            xj=c(1,nres+j)-xi
13513 !            yj=c(2,nres+j)-yi
13514 !            zj=c(3,nres+j)-zi
13515             xj=c(1,nres+j)
13516             yj=c(2,nres+j)
13517             zj=c(3,nres+j)
13518 ! Searching for nearest neighbour
13519           xj=mod(xj,boxxsize)
13520           if (xj.lt.0) xj=xj+boxxsize
13521           yj=mod(yj,boxysize)
13522           if (yj.lt.0) yj=yj+boxysize
13523           zj=mod(zj,boxzsize)
13524           if (zj.lt.0) zj=zj+boxzsize
13525        if ((zj.gt.bordlipbot)   &
13526       .and.(zj.lt.bordliptop)) then
13527 !C the energy transfer exist
13528         if (zj.lt.buflipbot) then
13529 !C what fraction I am in
13530          fracinbuf=1.0d0-  &
13531              ((zj-bordlipbot)/lipbufthick)
13532 !C lipbufthick is thickenes of lipid buffore
13533          sslipj=sscalelip(fracinbuf)
13534          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13535         elseif (zj.gt.bufliptop) then
13536          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13537          sslipj=sscalelip(fracinbuf)
13538          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13539         else
13540          sslipj=1.0d0
13541          ssgradlipj=0.0
13542         endif
13543        else
13544          sslipj=0.0d0
13545          ssgradlipj=0.0
13546        endif
13547       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13548        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13549       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13550        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13551
13552           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13553           xj_safe=xj
13554           yj_safe=yj
13555           zj_safe=zj
13556           subchap=0
13557
13558           do xshift=-1,1
13559           do yshift=-1,1
13560           do zshift=-1,1
13561           xj=xj_safe+xshift*boxxsize
13562           yj=yj_safe+yshift*boxysize
13563           zj=zj_safe+zshift*boxzsize
13564           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13565           if(dist_temp.lt.dist_init) then
13566             dist_init=dist_temp
13567             xj_temp=xj
13568             yj_temp=yj
13569             zj_temp=zj
13570             subchap=1
13571           endif
13572           enddo
13573           enddo
13574           enddo
13575           if (subchap.eq.1) then
13576           xj=xj_temp-xi
13577           yj=yj_temp-yi
13578           zj=zj_temp-zi
13579           else
13580           xj=xj_safe-xi
13581           yj=yj_safe-yi
13582           zj=zj_safe-zi
13583           endif
13584
13585             dxj=dc_norm(1,nres+j)
13586             dyj=dc_norm(2,nres+j)
13587             dzj=dc_norm(3,nres+j)
13588             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13589             rij=dsqrt(rrij)
13590             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13591             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13592             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13593             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13594             if (sss_ele_cut.le.0.0) cycle
13595
13596             if (sss.gt.0.0d0) then
13597
13598 ! Calculate angle-dependent terms of energy and contributions to their
13599 ! derivatives.
13600               call sc_angular
13601               sigsq=1.0D0/sigsq
13602               sig=sig0ij*dsqrt(sigsq)
13603               rij_shift=1.0D0/rij-sig+sig0ij
13604 ! for diagnostics; uncomment
13605 !              rij_shift=1.2*sig0ij
13606 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13607               if (rij_shift.le.0.0D0) then
13608                 evdw=1.0D20
13609 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13610 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13611 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13612                 return
13613               endif
13614               sigder=-sig*sigsq
13615 !---------------------------------------------------------------
13616               rij_shift=1.0D0/rij_shift
13617               fac=rij_shift**expon
13618               e1=fac*fac*aa
13619               e2=fac*bb
13620               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13621               eps2der=evdwij*eps3rt
13622               eps3der=evdwij*eps2rt
13623 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13624 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13625               evdwij=evdwij*eps2rt*eps3rt
13626               evdw=evdw+evdwij*sss*sss_ele_cut
13627               if (lprn) then
13628               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13629               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13630               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13631                 restyp(itypi,1),i,restyp(itypj,1),j,&
13632                 epsi,sigm,chi1,chi2,chip1,chip2,&
13633                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13634                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13635                 evdwij
13636               endif
13637
13638               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13639                               'evdw',i,j,evdwij
13640 !              if (energy_dec) write (iout,*) &
13641 !                              'evdw',i,j,evdwij,"egb_short"
13642
13643 ! Calculate gradient components.
13644               e1=e1*eps1*eps2rt**2*eps3rt**2
13645               fac=-expon*(e1+evdwij)*rij_shift
13646               sigder=fac*sigder
13647               fac=rij*fac
13648               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13649             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13650             /sigmaii(itypi,itypj))
13651
13652 !              fac=0.0d0
13653 ! Calculate the radial part of the gradient
13654               gg(1)=xj*fac
13655               gg(2)=yj*fac
13656               gg(3)=zj*fac
13657 ! Calculate angular part of the gradient.
13658               call sc_grad_scale(sss)
13659             endif
13660           ENDIF !mask_dyn_ss
13661           enddo      ! j
13662         enddo        ! iint
13663       enddo          ! i
13664 !      write (iout,*) "Number of loop steps in EGB:",ind
13665 !ccc      energy_dec=.false.
13666       return
13667       end subroutine egb_short
13668 !-----------------------------------------------------------------------------
13669       subroutine egbv_long(evdw)
13670 !
13671 ! This subroutine calculates the interaction energy of nonbonded side chains
13672 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13673 !
13674       use calc_data
13675 !      implicit real*8 (a-h,o-z)
13676 !      include 'DIMENSIONS'
13677 !      include 'COMMON.GEO'
13678 !      include 'COMMON.VAR'
13679 !      include 'COMMON.LOCAL'
13680 !      include 'COMMON.CHAIN'
13681 !      include 'COMMON.DERIV'
13682 !      include 'COMMON.NAMES'
13683 !      include 'COMMON.INTERACT'
13684 !      include 'COMMON.IOUNITS'
13685 !      include 'COMMON.CALC'
13686       use comm_srutu
13687 !el      integer :: icall
13688 !el      common /srutu/ icall
13689       logical :: lprn
13690 !el local variables
13691       integer :: iint,itypi,itypi1,itypj
13692       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13693       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13694       evdw=0.0D0
13695 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13696       evdw=0.0D0
13697       lprn=.false.
13698 !     if (icall.eq.0) lprn=.true.
13699 !el      ind=0
13700       do i=iatsc_s,iatsc_e
13701         itypi=itype(i,1)
13702         if (itypi.eq.ntyp1) cycle
13703         itypi1=itype(i+1,1)
13704         xi=c(1,nres+i)
13705         yi=c(2,nres+i)
13706         zi=c(3,nres+i)
13707         dxi=dc_norm(1,nres+i)
13708         dyi=dc_norm(2,nres+i)
13709         dzi=dc_norm(3,nres+i)
13710 !        dsci_inv=dsc_inv(itypi)
13711         dsci_inv=vbld_inv(i+nres)
13712 !
13713 ! Calculate SC interaction energy.
13714 !
13715         do iint=1,nint_gr(i)
13716           do j=istart(i,iint),iend(i,iint)
13717 !el            ind=ind+1
13718             itypj=itype(j,1)
13719             if (itypj.eq.ntyp1) cycle
13720 !            dscj_inv=dsc_inv(itypj)
13721             dscj_inv=vbld_inv(j+nres)
13722             sig0ij=sigma(itypi,itypj)
13723             r0ij=r0(itypi,itypj)
13724             chi1=chi(itypi,itypj)
13725             chi2=chi(itypj,itypi)
13726             chi12=chi1*chi2
13727             chip1=chip(itypi)
13728             chip2=chip(itypj)
13729             chip12=chip1*chip2
13730             alf1=alp(itypi)
13731             alf2=alp(itypj)
13732             alf12=0.5D0*(alf1+alf2)
13733             xj=c(1,nres+j)-xi
13734             yj=c(2,nres+j)-yi
13735             zj=c(3,nres+j)-zi
13736             dxj=dc_norm(1,nres+j)
13737             dyj=dc_norm(2,nres+j)
13738             dzj=dc_norm(3,nres+j)
13739             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13740             rij=dsqrt(rrij)
13741
13742             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13743
13744             if (sss.lt.1.0d0) then
13745
13746 ! Calculate angle-dependent terms of energy and contributions to their
13747 ! derivatives.
13748               call sc_angular
13749               sigsq=1.0D0/sigsq
13750               sig=sig0ij*dsqrt(sigsq)
13751               rij_shift=1.0D0/rij-sig+r0ij
13752 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13753               if (rij_shift.le.0.0D0) then
13754                 evdw=1.0D20
13755                 return
13756               endif
13757               sigder=-sig*sigsq
13758 !---------------------------------------------------------------
13759               rij_shift=1.0D0/rij_shift
13760               fac=rij_shift**expon
13761               e1=fac*fac*aa_aq(itypi,itypj)
13762               e2=fac*bb_aq(itypi,itypj)
13763               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13764               eps2der=evdwij*eps3rt
13765               eps3der=evdwij*eps2rt
13766               fac_augm=rrij**expon
13767               e_augm=augm(itypi,itypj)*fac_augm
13768               evdwij=evdwij*eps2rt*eps3rt
13769               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13770               if (lprn) then
13771               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13772               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13773               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13774                 restyp(itypi,1),i,restyp(itypj,1),j,&
13775                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13776                 chi1,chi2,chip1,chip2,&
13777                 eps1,eps2rt**2,eps3rt**2,&
13778                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13779                 evdwij+e_augm
13780               endif
13781 ! Calculate gradient components.
13782               e1=e1*eps1*eps2rt**2*eps3rt**2
13783               fac=-expon*(e1+evdwij)*rij_shift
13784               sigder=fac*sigder
13785               fac=rij*fac-2*expon*rrij*e_augm
13786 ! Calculate the radial part of the gradient
13787               gg(1)=xj*fac
13788               gg(2)=yj*fac
13789               gg(3)=zj*fac
13790 ! Calculate angular part of the gradient.
13791               call sc_grad_scale(1.0d0-sss)
13792             endif
13793           enddo      ! j
13794         enddo        ! iint
13795       enddo          ! i
13796       end subroutine egbv_long
13797 !-----------------------------------------------------------------------------
13798       subroutine egbv_short(evdw)
13799 !
13800 ! This subroutine calculates the interaction energy of nonbonded side chains
13801 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13802 !
13803       use calc_data
13804 !      implicit real*8 (a-h,o-z)
13805 !      include 'DIMENSIONS'
13806 !      include 'COMMON.GEO'
13807 !      include 'COMMON.VAR'
13808 !      include 'COMMON.LOCAL'
13809 !      include 'COMMON.CHAIN'
13810 !      include 'COMMON.DERIV'
13811 !      include 'COMMON.NAMES'
13812 !      include 'COMMON.INTERACT'
13813 !      include 'COMMON.IOUNITS'
13814 !      include 'COMMON.CALC'
13815       use comm_srutu
13816 !el      integer :: icall
13817 !el      common /srutu/ icall
13818       logical :: lprn
13819 !el local variables
13820       integer :: iint,itypi,itypi1,itypj
13821       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13822       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13823       evdw=0.0D0
13824 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13825       evdw=0.0D0
13826       lprn=.false.
13827 !     if (icall.eq.0) lprn=.true.
13828 !el      ind=0
13829       do i=iatsc_s,iatsc_e
13830         itypi=itype(i,1)
13831         if (itypi.eq.ntyp1) cycle
13832         itypi1=itype(i+1,1)
13833         xi=c(1,nres+i)
13834         yi=c(2,nres+i)
13835         zi=c(3,nres+i)
13836         dxi=dc_norm(1,nres+i)
13837         dyi=dc_norm(2,nres+i)
13838         dzi=dc_norm(3,nres+i)
13839 !        dsci_inv=dsc_inv(itypi)
13840         dsci_inv=vbld_inv(i+nres)
13841 !
13842 ! Calculate SC interaction energy.
13843 !
13844         do iint=1,nint_gr(i)
13845           do j=istart(i,iint),iend(i,iint)
13846 !el            ind=ind+1
13847             itypj=itype(j,1)
13848             if (itypj.eq.ntyp1) cycle
13849 !            dscj_inv=dsc_inv(itypj)
13850             dscj_inv=vbld_inv(j+nres)
13851             sig0ij=sigma(itypi,itypj)
13852             r0ij=r0(itypi,itypj)
13853             chi1=chi(itypi,itypj)
13854             chi2=chi(itypj,itypi)
13855             chi12=chi1*chi2
13856             chip1=chip(itypi)
13857             chip2=chip(itypj)
13858             chip12=chip1*chip2
13859             alf1=alp(itypi)
13860             alf2=alp(itypj)
13861             alf12=0.5D0*(alf1+alf2)
13862             xj=c(1,nres+j)-xi
13863             yj=c(2,nres+j)-yi
13864             zj=c(3,nres+j)-zi
13865             dxj=dc_norm(1,nres+j)
13866             dyj=dc_norm(2,nres+j)
13867             dzj=dc_norm(3,nres+j)
13868             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13869             rij=dsqrt(rrij)
13870
13871             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13872
13873             if (sss.gt.0.0d0) then
13874
13875 ! Calculate angle-dependent terms of energy and contributions to their
13876 ! derivatives.
13877               call sc_angular
13878               sigsq=1.0D0/sigsq
13879               sig=sig0ij*dsqrt(sigsq)
13880               rij_shift=1.0D0/rij-sig+r0ij
13881 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13882               if (rij_shift.le.0.0D0) then
13883                 evdw=1.0D20
13884                 return
13885               endif
13886               sigder=-sig*sigsq
13887 !---------------------------------------------------------------
13888               rij_shift=1.0D0/rij_shift
13889               fac=rij_shift**expon
13890               e1=fac*fac*aa_aq(itypi,itypj)
13891               e2=fac*bb_aq(itypi,itypj)
13892               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13893               eps2der=evdwij*eps3rt
13894               eps3der=evdwij*eps2rt
13895               fac_augm=rrij**expon
13896               e_augm=augm(itypi,itypj)*fac_augm
13897               evdwij=evdwij*eps2rt*eps3rt
13898               evdw=evdw+(evdwij+e_augm)*sss
13899               if (lprn) then
13900               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13901               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13902               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13903                 restyp(itypi,1),i,restyp(itypj,1),j,&
13904                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13905                 chi1,chi2,chip1,chip2,&
13906                 eps1,eps2rt**2,eps3rt**2,&
13907                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13908                 evdwij+e_augm
13909               endif
13910 ! Calculate gradient components.
13911               e1=e1*eps1*eps2rt**2*eps3rt**2
13912               fac=-expon*(e1+evdwij)*rij_shift
13913               sigder=fac*sigder
13914               fac=rij*fac-2*expon*rrij*e_augm
13915 ! Calculate the radial part of the gradient
13916               gg(1)=xj*fac
13917               gg(2)=yj*fac
13918               gg(3)=zj*fac
13919 ! Calculate angular part of the gradient.
13920               call sc_grad_scale(sss)
13921             endif
13922           enddo      ! j
13923         enddo        ! iint
13924       enddo          ! i
13925       end subroutine egbv_short
13926 !-----------------------------------------------------------------------------
13927       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13928 !
13929 ! This subroutine calculates the average interaction energy and its gradient
13930 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13931 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13932 ! The potential depends both on the distance of peptide-group centers and on
13933 ! the orientation of the CA-CA virtual bonds.
13934 !
13935 !      implicit real*8 (a-h,o-z)
13936
13937       use comm_locel
13938 #ifdef MPI
13939       include 'mpif.h'
13940 #endif
13941 !      include 'DIMENSIONS'
13942 !      include 'COMMON.CONTROL'
13943 !      include 'COMMON.SETUP'
13944 !      include 'COMMON.IOUNITS'
13945 !      include 'COMMON.GEO'
13946 !      include 'COMMON.VAR'
13947 !      include 'COMMON.LOCAL'
13948 !      include 'COMMON.CHAIN'
13949 !      include 'COMMON.DERIV'
13950 !      include 'COMMON.INTERACT'
13951 !      include 'COMMON.CONTACTS'
13952 !      include 'COMMON.TORSION'
13953 !      include 'COMMON.VECTORS'
13954 !      include 'COMMON.FFIELD'
13955 !      include 'COMMON.TIME1'
13956       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13957       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13958       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13959 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13960       real(kind=8),dimension(4) :: muij
13961 !el      integer :: num_conti,j1,j2
13962 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13963 !el                   dz_normi,xmedi,ymedi,zmedi
13964 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13965 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13966 !el          num_conti,j1,j2
13967 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13968 #ifdef MOMENT
13969       real(kind=8) :: scal_el=1.0d0
13970 #else
13971       real(kind=8) :: scal_el=0.5d0
13972 #endif
13973 ! 12/13/98
13974 ! 13-go grudnia roku pamietnego...
13975       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13976                                              0.0d0,1.0d0,0.0d0,&
13977                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13978 !el local variables
13979       integer :: i,j,k
13980       real(kind=8) :: fac
13981       real(kind=8) :: dxj,dyj,dzj
13982       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13983
13984 !      allocate(num_cont_hb(nres)) !(maxres)
13985 !d      write(iout,*) 'In EELEC'
13986 !d      do i=1,nloctyp
13987 !d        write(iout,*) 'Type',i
13988 !d        write(iout,*) 'B1',B1(:,i)
13989 !d        write(iout,*) 'B2',B2(:,i)
13990 !d        write(iout,*) 'CC',CC(:,:,i)
13991 !d        write(iout,*) 'DD',DD(:,:,i)
13992 !d        write(iout,*) 'EE',EE(:,:,i)
13993 !d      enddo
13994 !d      call check_vecgrad
13995 !d      stop
13996       if (icheckgrad.eq.1) then
13997         do i=1,nres-1
13998           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13999           do k=1,3
14000             dc_norm(k,i)=dc(k,i)*fac
14001           enddo
14002 !          write (iout,*) 'i',i,' fac',fac
14003         enddo
14004       endif
14005       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14006           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14007           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14008 !        call vec_and_deriv
14009 #ifdef TIMING
14010         time01=MPI_Wtime()
14011 #endif
14012 !        print *, "before set matrices"
14013         call set_matrices
14014 !        print *,"after set martices"
14015 #ifdef TIMING
14016         time_mat=time_mat+MPI_Wtime()-time01
14017 #endif
14018       endif
14019 !d      do i=1,nres-1
14020 !d        write (iout,*) 'i=',i
14021 !d        do k=1,3
14022 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14023 !d        enddo
14024 !d        do k=1,3
14025 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14026 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14027 !d        enddo
14028 !d      enddo
14029       t_eelecij=0.0d0
14030       ees=0.0D0
14031       evdw1=0.0D0
14032       eel_loc=0.0d0
14033       eello_turn3=0.0d0
14034       eello_turn4=0.0d0
14035 !el      ind=0
14036       do i=1,nres
14037         num_cont_hb(i)=0
14038       enddo
14039 !d      print '(a)','Enter EELEC'
14040 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14041 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14042 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14043       do i=1,nres
14044         gel_loc_loc(i)=0.0d0
14045         gcorr_loc(i)=0.0d0
14046       enddo
14047 !
14048 !
14049 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14050 !
14051 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14052 !
14053       do i=iturn3_start,iturn3_end
14054         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14055         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14056         dxi=dc(1,i)
14057         dyi=dc(2,i)
14058         dzi=dc(3,i)
14059         dx_normi=dc_norm(1,i)
14060         dy_normi=dc_norm(2,i)
14061         dz_normi=dc_norm(3,i)
14062         xmedi=c(1,i)+0.5d0*dxi
14063         ymedi=c(2,i)+0.5d0*dyi
14064         zmedi=c(3,i)+0.5d0*dzi
14065           xmedi=dmod(xmedi,boxxsize)
14066           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14067           ymedi=dmod(ymedi,boxysize)
14068           if (ymedi.lt.0) ymedi=ymedi+boxysize
14069           zmedi=dmod(zmedi,boxzsize)
14070           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14071         num_conti=0
14072         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14073         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14074         num_cont_hb(i)=num_conti
14075       enddo
14076       do i=iturn4_start,iturn4_end
14077         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14078           .or. itype(i+3,1).eq.ntyp1 &
14079           .or. itype(i+4,1).eq.ntyp1) cycle
14080         dxi=dc(1,i)
14081         dyi=dc(2,i)
14082         dzi=dc(3,i)
14083         dx_normi=dc_norm(1,i)
14084         dy_normi=dc_norm(2,i)
14085         dz_normi=dc_norm(3,i)
14086         xmedi=c(1,i)+0.5d0*dxi
14087         ymedi=c(2,i)+0.5d0*dyi
14088         zmedi=c(3,i)+0.5d0*dzi
14089           xmedi=dmod(xmedi,boxxsize)
14090           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14091           ymedi=dmod(ymedi,boxysize)
14092           if (ymedi.lt.0) ymedi=ymedi+boxysize
14093           zmedi=dmod(zmedi,boxzsize)
14094           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14095         num_conti=num_cont_hb(i)
14096         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14097         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14098           call eturn4(i,eello_turn4)
14099         num_cont_hb(i)=num_conti
14100       enddo   ! i
14101 !
14102 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14103 !
14104       do i=iatel_s,iatel_e
14105         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14106         dxi=dc(1,i)
14107         dyi=dc(2,i)
14108         dzi=dc(3,i)
14109         dx_normi=dc_norm(1,i)
14110         dy_normi=dc_norm(2,i)
14111         dz_normi=dc_norm(3,i)
14112         xmedi=c(1,i)+0.5d0*dxi
14113         ymedi=c(2,i)+0.5d0*dyi
14114         zmedi=c(3,i)+0.5d0*dzi
14115           xmedi=dmod(xmedi,boxxsize)
14116           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14117           ymedi=dmod(ymedi,boxysize)
14118           if (ymedi.lt.0) ymedi=ymedi+boxysize
14119           zmedi=dmod(zmedi,boxzsize)
14120           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14121 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14122         num_conti=num_cont_hb(i)
14123         do j=ielstart(i),ielend(i)
14124           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14125           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14126         enddo ! j
14127         num_cont_hb(i)=num_conti
14128       enddo   ! i
14129 !      write (iout,*) "Number of loop steps in EELEC:",ind
14130 !d      do i=1,nres
14131 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14132 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14133 !d      enddo
14134 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14135 !cc      eel_loc=eel_loc+eello_turn3
14136 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14137       return
14138       end subroutine eelec_scale
14139 !-----------------------------------------------------------------------------
14140       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14141 !      implicit real*8 (a-h,o-z)
14142
14143       use comm_locel
14144 !      include 'DIMENSIONS'
14145 #ifdef MPI
14146       include "mpif.h"
14147 #endif
14148 !      include 'COMMON.CONTROL'
14149 !      include 'COMMON.IOUNITS'
14150 !      include 'COMMON.GEO'
14151 !      include 'COMMON.VAR'
14152 !      include 'COMMON.LOCAL'
14153 !      include 'COMMON.CHAIN'
14154 !      include 'COMMON.DERIV'
14155 !      include 'COMMON.INTERACT'
14156 !      include 'COMMON.CONTACTS'
14157 !      include 'COMMON.TORSION'
14158 !      include 'COMMON.VECTORS'
14159 !      include 'COMMON.FFIELD'
14160 !      include 'COMMON.TIME1'
14161       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14162       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14163       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14164 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14165       real(kind=8),dimension(4) :: muij
14166       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14167                     dist_temp, dist_init,sss_grad
14168       integer xshift,yshift,zshift
14169
14170 !el      integer :: num_conti,j1,j2
14171 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14172 !el                   dz_normi,xmedi,ymedi,zmedi
14173 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14174 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14175 !el          num_conti,j1,j2
14176 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14177 #ifdef MOMENT
14178       real(kind=8) :: scal_el=1.0d0
14179 #else
14180       real(kind=8) :: scal_el=0.5d0
14181 #endif
14182 ! 12/13/98
14183 ! 13-go grudnia roku pamietnego...
14184       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14185                                              0.0d0,1.0d0,0.0d0,&
14186                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14187 !el local variables
14188       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14189       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14190       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14191       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14192       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14193       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14194       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14195                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14196                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14197                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14198                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14199                   ecosam,ecosbm,ecosgm,ghalf,time00
14200 !      integer :: maxconts
14201 !      maxconts = nres/4
14202 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14203 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14204 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14205 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14206 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14207 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14208 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14209 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14210 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14211 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14212 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14213 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14214 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14215
14216 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14217 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14218
14219 #ifdef MPI
14220           time00=MPI_Wtime()
14221 #endif
14222 !d      write (iout,*) "eelecij",i,j
14223 !el          ind=ind+1
14224           iteli=itel(i)
14225           itelj=itel(j)
14226           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14227           aaa=app(iteli,itelj)
14228           bbb=bpp(iteli,itelj)
14229           ael6i=ael6(iteli,itelj)
14230           ael3i=ael3(iteli,itelj)
14231           dxj=dc(1,j)
14232           dyj=dc(2,j)
14233           dzj=dc(3,j)
14234           dx_normj=dc_norm(1,j)
14235           dy_normj=dc_norm(2,j)
14236           dz_normj=dc_norm(3,j)
14237 !          xj=c(1,j)+0.5D0*dxj-xmedi
14238 !          yj=c(2,j)+0.5D0*dyj-ymedi
14239 !          zj=c(3,j)+0.5D0*dzj-zmedi
14240           xj=c(1,j)+0.5D0*dxj
14241           yj=c(2,j)+0.5D0*dyj
14242           zj=c(3,j)+0.5D0*dzj
14243           xj=mod(xj,boxxsize)
14244           if (xj.lt.0) xj=xj+boxxsize
14245           yj=mod(yj,boxysize)
14246           if (yj.lt.0) yj=yj+boxysize
14247           zj=mod(zj,boxzsize)
14248           if (zj.lt.0) zj=zj+boxzsize
14249       isubchap=0
14250       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14251       xj_safe=xj
14252       yj_safe=yj
14253       zj_safe=zj
14254       do xshift=-1,1
14255       do yshift=-1,1
14256       do zshift=-1,1
14257           xj=xj_safe+xshift*boxxsize
14258           yj=yj_safe+yshift*boxysize
14259           zj=zj_safe+zshift*boxzsize
14260           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14261           if(dist_temp.lt.dist_init) then
14262             dist_init=dist_temp
14263             xj_temp=xj
14264             yj_temp=yj
14265             zj_temp=zj
14266             isubchap=1
14267           endif
14268        enddo
14269        enddo
14270        enddo
14271        if (isubchap.eq.1) then
14272 !C          print *,i,j
14273           xj=xj_temp-xmedi
14274           yj=yj_temp-ymedi
14275           zj=zj_temp-zmedi
14276        else
14277           xj=xj_safe-xmedi
14278           yj=yj_safe-ymedi
14279           zj=zj_safe-zmedi
14280        endif
14281
14282           rij=xj*xj+yj*yj+zj*zj
14283           rrmij=1.0D0/rij
14284           rij=dsqrt(rij)
14285           rmij=1.0D0/rij
14286 ! For extracting the short-range part of Evdwpp
14287           sss=sscale(rij/rpp(iteli,itelj))
14288             sss_ele_cut=sscale_ele(rij)
14289             sss_ele_grad=sscagrad_ele(rij)
14290             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14291 !             sss_ele_cut=1.0d0
14292 !             sss_ele_grad=0.0d0
14293             if (sss_ele_cut.le.0.0) go to 128
14294
14295           r3ij=rrmij*rmij
14296           r6ij=r3ij*r3ij
14297           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14298           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14299           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14300           fac=cosa-3.0D0*cosb*cosg
14301           ev1=aaa*r6ij*r6ij
14302 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14303           if (j.eq.i+2) ev1=scal_el*ev1
14304           ev2=bbb*r6ij
14305           fac3=ael6i*r6ij
14306           fac4=ael3i*r3ij
14307           evdwij=ev1+ev2
14308           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14309           el2=fac4*fac
14310           eesij=el1+el2
14311 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14312           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14313           ees=ees+eesij*sss_ele_cut
14314           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14315 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14316 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14317 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14318 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14319
14320           if (energy_dec) then
14321               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14322               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14323           endif
14324
14325 !
14326 ! Calculate contributions to the Cartesian gradient.
14327 !
14328 #ifdef SPLITELE
14329           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14330           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14331           fac1=fac
14332           erij(1)=xj*rmij
14333           erij(2)=yj*rmij
14334           erij(3)=zj*rmij
14335 !
14336 ! Radial derivatives. First process both termini of the fragment (i,j)
14337 !
14338           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14339           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14340           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14341 !          do k=1,3
14342 !            ghalf=0.5D0*ggg(k)
14343 !            gelc(k,i)=gelc(k,i)+ghalf
14344 !            gelc(k,j)=gelc(k,j)+ghalf
14345 !          enddo
14346 ! 9/28/08 AL Gradient compotents will be summed only at the end
14347           do k=1,3
14348             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14349             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14350           enddo
14351 !
14352 ! Loop over residues i+1 thru j-1.
14353 !
14354 !grad          do k=i+1,j-1
14355 !grad            do l=1,3
14356 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14357 !grad            enddo
14358 !grad          enddo
14359           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14360           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14361           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14362           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14363           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14364           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14365 !          do k=1,3
14366 !            ghalf=0.5D0*ggg(k)
14367 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14368 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14369 !          enddo
14370 ! 9/28/08 AL Gradient compotents will be summed only at the end
14371           do k=1,3
14372             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14373             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14374           enddo
14375 !
14376 ! Loop over residues i+1 thru j-1.
14377 !
14378 !grad          do k=i+1,j-1
14379 !grad            do l=1,3
14380 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14381 !grad            enddo
14382 !grad          enddo
14383 #else
14384           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14385           facel=(el1+eesij)*sss_ele_cut
14386           fac1=fac
14387           fac=-3*rrmij*(facvdw+facvdw+facel)
14388           erij(1)=xj*rmij
14389           erij(2)=yj*rmij
14390           erij(3)=zj*rmij
14391 !
14392 ! Radial derivatives. First process both termini of the fragment (i,j)
14393 !
14394           ggg(1)=fac*xj
14395           ggg(2)=fac*yj
14396           ggg(3)=fac*zj
14397 !          do k=1,3
14398 !            ghalf=0.5D0*ggg(k)
14399 !            gelc(k,i)=gelc(k,i)+ghalf
14400 !            gelc(k,j)=gelc(k,j)+ghalf
14401 !          enddo
14402 ! 9/28/08 AL Gradient compotents will be summed only at the end
14403           do k=1,3
14404             gelc_long(k,j)=gelc(k,j)+ggg(k)
14405             gelc_long(k,i)=gelc(k,i)-ggg(k)
14406           enddo
14407 !
14408 ! Loop over residues i+1 thru j-1.
14409 !
14410 !grad          do k=i+1,j-1
14411 !grad            do l=1,3
14412 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14413 !grad            enddo
14414 !grad          enddo
14415 ! 9/28/08 AL Gradient compotents will be summed only at the end
14416           ggg(1)=facvdw*xj
14417           ggg(2)=facvdw*yj
14418           ggg(3)=facvdw*zj
14419           do k=1,3
14420             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14421             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14422           enddo
14423 #endif
14424 !
14425 ! Angular part
14426 !
14427           ecosa=2.0D0*fac3*fac1+fac4
14428           fac4=-3.0D0*fac4
14429           fac3=-6.0D0*fac3
14430           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14431           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14432           do k=1,3
14433             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14434             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14435           enddo
14436 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14437 !d   &          (dcosg(k),k=1,3)
14438           do k=1,3
14439             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14440           enddo
14441 !          do k=1,3
14442 !            ghalf=0.5D0*ggg(k)
14443 !            gelc(k,i)=gelc(k,i)+ghalf
14444 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14445 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14446 !            gelc(k,j)=gelc(k,j)+ghalf
14447 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14448 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14449 !          enddo
14450 !grad          do k=i+1,j-1
14451 !grad            do l=1,3
14452 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14453 !grad            enddo
14454 !grad          enddo
14455           do k=1,3
14456             gelc(k,i)=gelc(k,i) &
14457                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14458                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14459                      *sss_ele_cut
14460             gelc(k,j)=gelc(k,j) &
14461                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14462                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14463                      *sss_ele_cut
14464             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14465             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14466           enddo
14467           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14468               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14469               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14470 !
14471 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14472 !   energy of a peptide unit is assumed in the form of a second-order
14473 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14474 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14475 !   are computed for EVERY pair of non-contiguous peptide groups.
14476 !
14477           if (j.lt.nres-1) then
14478             j1=j+1
14479             j2=j-1
14480           else
14481             j1=j-1
14482             j2=j-2
14483           endif
14484           kkk=0
14485           do k=1,2
14486             do l=1,2
14487               kkk=kkk+1
14488               muij(kkk)=mu(k,i)*mu(l,j)
14489             enddo
14490           enddo
14491 !d         write (iout,*) 'EELEC: i',i,' j',j
14492 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14493 !d          write(iout,*) 'muij',muij
14494           ury=scalar(uy(1,i),erij)
14495           urz=scalar(uz(1,i),erij)
14496           vry=scalar(uy(1,j),erij)
14497           vrz=scalar(uz(1,j),erij)
14498           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14499           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14500           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14501           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14502           fac=dsqrt(-ael6i)*r3ij
14503           a22=a22*fac
14504           a23=a23*fac
14505           a32=a32*fac
14506           a33=a33*fac
14507 !d          write (iout,'(4i5,4f10.5)')
14508 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14509 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14510 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14511 !d     &      uy(:,j),uz(:,j)
14512 !d          write (iout,'(4f10.5)')
14513 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14514 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14515 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14516 !d           write (iout,'(9f10.5/)')
14517 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14518 ! Derivatives of the elements of A in virtual-bond vectors
14519           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14520           do k=1,3
14521             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14522             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14523             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14524             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14525             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14526             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14527             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14528             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14529             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14530             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14531             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14532             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14533           enddo
14534 ! Compute radial contributions to the gradient
14535           facr=-3.0d0*rrmij
14536           a22der=a22*facr
14537           a23der=a23*facr
14538           a32der=a32*facr
14539           a33der=a33*facr
14540           agg(1,1)=a22der*xj
14541           agg(2,1)=a22der*yj
14542           agg(3,1)=a22der*zj
14543           agg(1,2)=a23der*xj
14544           agg(2,2)=a23der*yj
14545           agg(3,2)=a23der*zj
14546           agg(1,3)=a32der*xj
14547           agg(2,3)=a32der*yj
14548           agg(3,3)=a32der*zj
14549           agg(1,4)=a33der*xj
14550           agg(2,4)=a33der*yj
14551           agg(3,4)=a33der*zj
14552 ! Add the contributions coming from er
14553           fac3=-3.0d0*fac
14554           do k=1,3
14555             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14556             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14557             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14558             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14559           enddo
14560           do k=1,3
14561 ! Derivatives in DC(i)
14562 !grad            ghalf1=0.5d0*agg(k,1)
14563 !grad            ghalf2=0.5d0*agg(k,2)
14564 !grad            ghalf3=0.5d0*agg(k,3)
14565 !grad            ghalf4=0.5d0*agg(k,4)
14566             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14567             -3.0d0*uryg(k,2)*vry)!+ghalf1
14568             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14569             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14570             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14571             -3.0d0*urzg(k,2)*vry)!+ghalf3
14572             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14573             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14574 ! Derivatives in DC(i+1)
14575             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14576             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14577             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14578             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14579             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14580             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14581             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14582             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14583 ! Derivatives in DC(j)
14584             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14585             -3.0d0*vryg(k,2)*ury)!+ghalf1
14586             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14587             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14588             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14589             -3.0d0*vryg(k,2)*urz)!+ghalf3
14590             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14591             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14592 ! Derivatives in DC(j+1) or DC(nres-1)
14593             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14594             -3.0d0*vryg(k,3)*ury)
14595             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14596             -3.0d0*vrzg(k,3)*ury)
14597             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14598             -3.0d0*vryg(k,3)*urz)
14599             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14600             -3.0d0*vrzg(k,3)*urz)
14601 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14602 !grad              do l=1,4
14603 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14604 !grad              enddo
14605 !grad            endif
14606           enddo
14607           acipa(1,1)=a22
14608           acipa(1,2)=a23
14609           acipa(2,1)=a32
14610           acipa(2,2)=a33
14611           a22=-a22
14612           a23=-a23
14613           do l=1,2
14614             do k=1,3
14615               agg(k,l)=-agg(k,l)
14616               aggi(k,l)=-aggi(k,l)
14617               aggi1(k,l)=-aggi1(k,l)
14618               aggj(k,l)=-aggj(k,l)
14619               aggj1(k,l)=-aggj1(k,l)
14620             enddo
14621           enddo
14622           if (j.lt.nres-1) then
14623             a22=-a22
14624             a32=-a32
14625             do l=1,3,2
14626               do k=1,3
14627                 agg(k,l)=-agg(k,l)
14628                 aggi(k,l)=-aggi(k,l)
14629                 aggi1(k,l)=-aggi1(k,l)
14630                 aggj(k,l)=-aggj(k,l)
14631                 aggj1(k,l)=-aggj1(k,l)
14632               enddo
14633             enddo
14634           else
14635             a22=-a22
14636             a23=-a23
14637             a32=-a32
14638             a33=-a33
14639             do l=1,4
14640               do k=1,3
14641                 agg(k,l)=-agg(k,l)
14642                 aggi(k,l)=-aggi(k,l)
14643                 aggi1(k,l)=-aggi1(k,l)
14644                 aggj(k,l)=-aggj(k,l)
14645                 aggj1(k,l)=-aggj1(k,l)
14646               enddo
14647             enddo
14648           endif
14649           ENDIF ! WCORR
14650           IF (wel_loc.gt.0.0d0) THEN
14651 ! Contribution to the local-electrostatic energy coming from the i-j pair
14652           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14653            +a33*muij(4)
14654 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14655
14656           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14657                   'eelloc',i,j,eel_loc_ij
14658 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14659
14660           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14661 ! Partial derivatives in virtual-bond dihedral angles gamma
14662           if (i.gt.1) &
14663           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14664                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14665                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14666                  *sss_ele_cut
14667           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14668                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14669                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14670                  *sss_ele_cut
14671            xtemp(1)=xj
14672            xtemp(2)=yj
14673            xtemp(3)=zj
14674
14675 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14676           do l=1,3
14677             ggg(l)=(agg(l,1)*muij(1)+ &
14678                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14679             *sss_ele_cut &
14680              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14681
14682             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14683             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14684 !grad            ghalf=0.5d0*ggg(l)
14685 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14686 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14687           enddo
14688 !grad          do k=i+1,j2
14689 !grad            do l=1,3
14690 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14691 !grad            enddo
14692 !grad          enddo
14693 ! Remaining derivatives of eello
14694           do l=1,3
14695             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14696                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14697             *sss_ele_cut
14698
14699             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14700                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14701             *sss_ele_cut
14702
14703             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14704                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14705             *sss_ele_cut
14706
14707             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14708                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14709             *sss_ele_cut
14710
14711           enddo
14712           ENDIF
14713 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14714 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14715           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14716              .and. num_conti.le.maxconts) then
14717 !            write (iout,*) i,j," entered corr"
14718 !
14719 ! Calculate the contact function. The ith column of the array JCONT will
14720 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14721 ! greater than I). The arrays FACONT and GACONT will contain the values of
14722 ! the contact function and its derivative.
14723 !           r0ij=1.02D0*rpp(iteli,itelj)
14724 !           r0ij=1.11D0*rpp(iteli,itelj)
14725             r0ij=2.20D0*rpp(iteli,itelj)
14726 !           r0ij=1.55D0*rpp(iteli,itelj)
14727             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14728 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14729             if (fcont.gt.0.0D0) then
14730               num_conti=num_conti+1
14731               if (num_conti.gt.maxconts) then
14732 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14733                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14734                                ' will skip next contacts for this conf.',num_conti
14735               else
14736                 jcont_hb(num_conti,i)=j
14737 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14738 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14739                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14740                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14741 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14742 !  terms.
14743                 d_cont(num_conti,i)=rij
14744 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14745 !     --- Electrostatic-interaction matrix ---
14746                 a_chuj(1,1,num_conti,i)=a22
14747                 a_chuj(1,2,num_conti,i)=a23
14748                 a_chuj(2,1,num_conti,i)=a32
14749                 a_chuj(2,2,num_conti,i)=a33
14750 !     --- Gradient of rij
14751                 do kkk=1,3
14752                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14753                 enddo
14754                 kkll=0
14755                 do k=1,2
14756                   do l=1,2
14757                     kkll=kkll+1
14758                     do m=1,3
14759                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14760                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14761                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14762                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14763                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14764                     enddo
14765                   enddo
14766                 enddo
14767                 ENDIF
14768                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14769 ! Calculate contact energies
14770                 cosa4=4.0D0*cosa
14771                 wij=cosa-3.0D0*cosb*cosg
14772                 cosbg1=cosb+cosg
14773                 cosbg2=cosb-cosg
14774 !               fac3=dsqrt(-ael6i)/r0ij**3
14775                 fac3=dsqrt(-ael6i)*r3ij
14776 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14777                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14778                 if (ees0tmp.gt.0) then
14779                   ees0pij=dsqrt(ees0tmp)
14780                 else
14781                   ees0pij=0
14782                 endif
14783 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14784                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14785                 if (ees0tmp.gt.0) then
14786                   ees0mij=dsqrt(ees0tmp)
14787                 else
14788                   ees0mij=0
14789                 endif
14790 !               ees0mij=0.0D0
14791                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14792                      *sss_ele_cut
14793
14794                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14795                      *sss_ele_cut
14796
14797 ! Diagnostics. Comment out or remove after debugging!
14798 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14799 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14800 !               ees0m(num_conti,i)=0.0D0
14801 ! End diagnostics.
14802 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14803 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14804 ! Angular derivatives of the contact function
14805                 ees0pij1=fac3/ees0pij
14806                 ees0mij1=fac3/ees0mij
14807                 fac3p=-3.0D0*fac3*rrmij
14808                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14809                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14810 !               ees0mij1=0.0D0
14811                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14812                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14813                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14814                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14815                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14816                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14817                 ecosap=ecosa1+ecosa2
14818                 ecosbp=ecosb1+ecosb2
14819                 ecosgp=ecosg1+ecosg2
14820                 ecosam=ecosa1-ecosa2
14821                 ecosbm=ecosb1-ecosb2
14822                 ecosgm=ecosg1-ecosg2
14823 ! Diagnostics
14824 !               ecosap=ecosa1
14825 !               ecosbp=ecosb1
14826 !               ecosgp=ecosg1
14827 !               ecosam=0.0D0
14828 !               ecosbm=0.0D0
14829 !               ecosgm=0.0D0
14830 ! End diagnostics
14831                 facont_hb(num_conti,i)=fcont
14832                 fprimcont=fprimcont/rij
14833 !d              facont_hb(num_conti,i)=1.0D0
14834 ! Following line is for diagnostics.
14835 !d              fprimcont=0.0D0
14836                 do k=1,3
14837                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14838                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14839                 enddo
14840                 do k=1,3
14841                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14842                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14843                 enddo
14844 !                gggp(1)=gggp(1)+ees0pijp*xj
14845 !                gggp(2)=gggp(2)+ees0pijp*yj
14846 !                gggp(3)=gggp(3)+ees0pijp*zj
14847 !                gggm(1)=gggm(1)+ees0mijp*xj
14848 !                gggm(2)=gggm(2)+ees0mijp*yj
14849 !                gggm(3)=gggm(3)+ees0mijp*zj
14850                 gggp(1)=gggp(1)+ees0pijp*xj &
14851                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14852                 gggp(2)=gggp(2)+ees0pijp*yj &
14853                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14854                 gggp(3)=gggp(3)+ees0pijp*zj &
14855                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14856
14857                 gggm(1)=gggm(1)+ees0mijp*xj &
14858                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14859
14860                 gggm(2)=gggm(2)+ees0mijp*yj &
14861                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14862
14863                 gggm(3)=gggm(3)+ees0mijp*zj &
14864                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14865
14866 ! Derivatives due to the contact function
14867                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14868                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14869                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14870                 do k=1,3
14871 !
14872 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14873 !          following the change of gradient-summation algorithm.
14874 !
14875 !grad                  ghalfp=0.5D0*gggp(k)
14876 !grad                  ghalfm=0.5D0*gggm(k)
14877 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14878 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14879 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14880 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14881 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14882 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14883 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14884 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14885 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14886 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14887 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14888 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14889 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14890 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14891                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14892                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14893                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14894                      *sss_ele_cut
14895
14896                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14897                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14898                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14899                      *sss_ele_cut
14900
14901                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14902                      *sss_ele_cut
14903
14904                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14905                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14906                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14907                      *sss_ele_cut
14908
14909                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14910                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14911                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14912                      *sss_ele_cut
14913
14914                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14915                      *sss_ele_cut
14916
14917                 enddo
14918               ENDIF ! wcorr
14919               endif  ! num_conti.le.maxconts
14920             endif  ! fcont.gt.0
14921           endif    ! j.gt.i+1
14922           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14923             do k=1,4
14924               do l=1,3
14925                 ghalf=0.5d0*agg(l,k)
14926                 aggi(l,k)=aggi(l,k)+ghalf
14927                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14928                 aggj(l,k)=aggj(l,k)+ghalf
14929               enddo
14930             enddo
14931             if (j.eq.nres-1 .and. i.lt.j-2) then
14932               do k=1,4
14933                 do l=1,3
14934                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14935                 enddo
14936               enddo
14937             endif
14938           endif
14939  128      continue
14940 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14941       return
14942       end subroutine eelecij_scale
14943 !-----------------------------------------------------------------------------
14944       subroutine evdwpp_short(evdw1)
14945 !
14946 ! Compute Evdwpp
14947 !
14948 !      implicit real*8 (a-h,o-z)
14949 !      include 'DIMENSIONS'
14950 !      include 'COMMON.CONTROL'
14951 !      include 'COMMON.IOUNITS'
14952 !      include 'COMMON.GEO'
14953 !      include 'COMMON.VAR'
14954 !      include 'COMMON.LOCAL'
14955 !      include 'COMMON.CHAIN'
14956 !      include 'COMMON.DERIV'
14957 !      include 'COMMON.INTERACT'
14958 !      include 'COMMON.CONTACTS'
14959 !      include 'COMMON.TORSION'
14960 !      include 'COMMON.VECTORS'
14961 !      include 'COMMON.FFIELD'
14962       real(kind=8),dimension(3) :: ggg
14963 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14964 #ifdef MOMENT
14965       real(kind=8) :: scal_el=1.0d0
14966 #else
14967       real(kind=8) :: scal_el=0.5d0
14968 #endif
14969 !el local variables
14970       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14971       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14972       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14973                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14974                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14975       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14976                     dist_temp, dist_init,sss_grad
14977       integer xshift,yshift,zshift
14978
14979
14980       evdw1=0.0D0
14981 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14982 !     & " iatel_e_vdw",iatel_e_vdw
14983       call flush(iout)
14984       do i=iatel_s_vdw,iatel_e_vdw
14985         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14986         dxi=dc(1,i)
14987         dyi=dc(2,i)
14988         dzi=dc(3,i)
14989         dx_normi=dc_norm(1,i)
14990         dy_normi=dc_norm(2,i)
14991         dz_normi=dc_norm(3,i)
14992         xmedi=c(1,i)+0.5d0*dxi
14993         ymedi=c(2,i)+0.5d0*dyi
14994         zmedi=c(3,i)+0.5d0*dzi
14995           xmedi=dmod(xmedi,boxxsize)
14996           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14997           ymedi=dmod(ymedi,boxysize)
14998           if (ymedi.lt.0) ymedi=ymedi+boxysize
14999           zmedi=dmod(zmedi,boxzsize)
15000           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15001         num_conti=0
15002 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15003 !     &   ' ielend',ielend_vdw(i)
15004         call flush(iout)
15005         do j=ielstart_vdw(i),ielend_vdw(i)
15006           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15007 !el          ind=ind+1
15008           iteli=itel(i)
15009           itelj=itel(j)
15010           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15011           aaa=app(iteli,itelj)
15012           bbb=bpp(iteli,itelj)
15013           dxj=dc(1,j)
15014           dyj=dc(2,j)
15015           dzj=dc(3,j)
15016           dx_normj=dc_norm(1,j)
15017           dy_normj=dc_norm(2,j)
15018           dz_normj=dc_norm(3,j)
15019 !          xj=c(1,j)+0.5D0*dxj-xmedi
15020 !          yj=c(2,j)+0.5D0*dyj-ymedi
15021 !          zj=c(3,j)+0.5D0*dzj-zmedi
15022           xj=c(1,j)+0.5D0*dxj
15023           yj=c(2,j)+0.5D0*dyj
15024           zj=c(3,j)+0.5D0*dzj
15025           xj=mod(xj,boxxsize)
15026           if (xj.lt.0) xj=xj+boxxsize
15027           yj=mod(yj,boxysize)
15028           if (yj.lt.0) yj=yj+boxysize
15029           zj=mod(zj,boxzsize)
15030           if (zj.lt.0) zj=zj+boxzsize
15031       isubchap=0
15032       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15033       xj_safe=xj
15034       yj_safe=yj
15035       zj_safe=zj
15036       do xshift=-1,1
15037       do yshift=-1,1
15038       do zshift=-1,1
15039           xj=xj_safe+xshift*boxxsize
15040           yj=yj_safe+yshift*boxysize
15041           zj=zj_safe+zshift*boxzsize
15042           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15043           if(dist_temp.lt.dist_init) then
15044             dist_init=dist_temp
15045             xj_temp=xj
15046             yj_temp=yj
15047             zj_temp=zj
15048             isubchap=1
15049           endif
15050        enddo
15051        enddo
15052        enddo
15053        if (isubchap.eq.1) then
15054 !C          print *,i,j
15055           xj=xj_temp-xmedi
15056           yj=yj_temp-ymedi
15057           zj=zj_temp-zmedi
15058        else
15059           xj=xj_safe-xmedi
15060           yj=yj_safe-ymedi
15061           zj=zj_safe-zmedi
15062        endif
15063
15064           rij=xj*xj+yj*yj+zj*zj
15065           rrmij=1.0D0/rij
15066           rij=dsqrt(rij)
15067           sss=sscale(rij/rpp(iteli,itelj))
15068             sss_ele_cut=sscale_ele(rij)
15069             sss_ele_grad=sscagrad_ele(rij)
15070             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15071             if (sss_ele_cut.le.0.0) cycle
15072           if (sss.gt.0.0d0) then
15073             rmij=1.0D0/rij
15074             r3ij=rrmij*rmij
15075             r6ij=r3ij*r3ij
15076             ev1=aaa*r6ij*r6ij
15077 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15078             if (j.eq.i+2) ev1=scal_el*ev1
15079             ev2=bbb*r6ij
15080             evdwij=ev1+ev2
15081             if (energy_dec) then
15082               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15083             endif
15084             evdw1=evdw1+evdwij*sss*sss_ele_cut
15085 !
15086 ! Calculate contributions to the Cartesian gradient.
15087 !
15088             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15089 !            ggg(1)=facvdw*xj
15090 !            ggg(2)=facvdw*yj
15091 !            ggg(3)=facvdw*zj
15092           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15093           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15094           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15095           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15096           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15097           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15098
15099             do k=1,3
15100               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15101               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15102             enddo
15103           endif
15104         enddo ! j
15105       enddo   ! i
15106       return
15107       end subroutine evdwpp_short
15108 !-----------------------------------------------------------------------------
15109       subroutine escp_long(evdw2,evdw2_14)
15110 !
15111 ! This subroutine calculates the excluded-volume interaction energy between
15112 ! peptide-group centers and side chains and its gradient in virtual-bond and
15113 ! side-chain vectors.
15114 !
15115 !      implicit real*8 (a-h,o-z)
15116 !      include 'DIMENSIONS'
15117 !      include 'COMMON.GEO'
15118 !      include 'COMMON.VAR'
15119 !      include 'COMMON.LOCAL'
15120 !      include 'COMMON.CHAIN'
15121 !      include 'COMMON.DERIV'
15122 !      include 'COMMON.INTERACT'
15123 !      include 'COMMON.FFIELD'
15124 !      include 'COMMON.IOUNITS'
15125 !      include 'COMMON.CONTROL'
15126       real(kind=8),dimension(3) :: ggg
15127 !el local variables
15128       integer :: i,iint,j,k,iteli,itypj,subchap
15129       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15130       real(kind=8) :: evdw2,evdw2_14,evdwij
15131       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15132                     dist_temp, dist_init
15133
15134       evdw2=0.0D0
15135       evdw2_14=0.0d0
15136 !d    print '(a)','Enter ESCP'
15137 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15138       do i=iatscp_s,iatscp_e
15139         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15140         iteli=itel(i)
15141         xi=0.5D0*(c(1,i)+c(1,i+1))
15142         yi=0.5D0*(c(2,i)+c(2,i+1))
15143         zi=0.5D0*(c(3,i)+c(3,i+1))
15144           xi=mod(xi,boxxsize)
15145           if (xi.lt.0) xi=xi+boxxsize
15146           yi=mod(yi,boxysize)
15147           if (yi.lt.0) yi=yi+boxysize
15148           zi=mod(zi,boxzsize)
15149           if (zi.lt.0) zi=zi+boxzsize
15150
15151         do iint=1,nscp_gr(i)
15152
15153         do j=iscpstart(i,iint),iscpend(i,iint)
15154           itypj=itype(j,1)
15155           if (itypj.eq.ntyp1) cycle
15156 ! Uncomment following three lines for SC-p interactions
15157 !         xj=c(1,nres+j)-xi
15158 !         yj=c(2,nres+j)-yi
15159 !         zj=c(3,nres+j)-zi
15160 ! Uncomment following three lines for Ca-p interactions
15161           xj=c(1,j)
15162           yj=c(2,j)
15163           zj=c(3,j)
15164           xj=mod(xj,boxxsize)
15165           if (xj.lt.0) xj=xj+boxxsize
15166           yj=mod(yj,boxysize)
15167           if (yj.lt.0) yj=yj+boxysize
15168           zj=mod(zj,boxzsize)
15169           if (zj.lt.0) zj=zj+boxzsize
15170       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15171       xj_safe=xj
15172       yj_safe=yj
15173       zj_safe=zj
15174       subchap=0
15175       do xshift=-1,1
15176       do yshift=-1,1
15177       do zshift=-1,1
15178           xj=xj_safe+xshift*boxxsize
15179           yj=yj_safe+yshift*boxysize
15180           zj=zj_safe+zshift*boxzsize
15181           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15182           if(dist_temp.lt.dist_init) then
15183             dist_init=dist_temp
15184             xj_temp=xj
15185             yj_temp=yj
15186             zj_temp=zj
15187             subchap=1
15188           endif
15189        enddo
15190        enddo
15191        enddo
15192        if (subchap.eq.1) then
15193           xj=xj_temp-xi
15194           yj=yj_temp-yi
15195           zj=zj_temp-zi
15196        else
15197           xj=xj_safe-xi
15198           yj=yj_safe-yi
15199           zj=zj_safe-zi
15200        endif
15201           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15202
15203           rij=dsqrt(1.0d0/rrij)
15204             sss_ele_cut=sscale_ele(rij)
15205             sss_ele_grad=sscagrad_ele(rij)
15206 !            print *,sss_ele_cut,sss_ele_grad,&
15207 !            (rij),r_cut_ele,rlamb_ele
15208             if (sss_ele_cut.le.0.0) cycle
15209           sss=sscale((rij/rscp(itypj,iteli)))
15210           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15211           if (sss.lt.1.0d0) then
15212
15213             fac=rrij**expon2
15214             e1=fac*fac*aad(itypj,iteli)
15215             e2=fac*bad(itypj,iteli)
15216             if (iabs(j-i) .le. 2) then
15217               e1=scal14*e1
15218               e2=scal14*e2
15219               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15220             endif
15221             evdwij=e1+e2
15222             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15223             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15224                 'evdw2',i,j,sss,evdwij
15225 !
15226 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15227 !
15228             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15229             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15230             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15231             ggg(1)=xj*fac
15232             ggg(2)=yj*fac
15233             ggg(3)=zj*fac
15234 ! Uncomment following three lines for SC-p interactions
15235 !           do k=1,3
15236 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15237 !           enddo
15238 ! Uncomment following line for SC-p interactions
15239 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15240             do k=1,3
15241               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15242               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15243             enddo
15244           endif
15245         enddo
15246
15247         enddo ! iint
15248       enddo ! i
15249       do i=1,nct
15250         do j=1,3
15251           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15252           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15253           gradx_scp(j,i)=expon*gradx_scp(j,i)
15254         enddo
15255       enddo
15256 !******************************************************************************
15257 !
15258 !                              N O T E !!!
15259 !
15260 ! To save time the factor EXPON has been extracted from ALL components
15261 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15262 ! use!
15263 !
15264 !******************************************************************************
15265       return
15266       end subroutine escp_long
15267 !-----------------------------------------------------------------------------
15268       subroutine escp_short(evdw2,evdw2_14)
15269 !
15270 ! This subroutine calculates the excluded-volume interaction energy between
15271 ! peptide-group centers and side chains and its gradient in virtual-bond and
15272 ! side-chain vectors.
15273 !
15274 !      implicit real*8 (a-h,o-z)
15275 !      include 'DIMENSIONS'
15276 !      include 'COMMON.GEO'
15277 !      include 'COMMON.VAR'
15278 !      include 'COMMON.LOCAL'
15279 !      include 'COMMON.CHAIN'
15280 !      include 'COMMON.DERIV'
15281 !      include 'COMMON.INTERACT'
15282 !      include 'COMMON.FFIELD'
15283 !      include 'COMMON.IOUNITS'
15284 !      include 'COMMON.CONTROL'
15285       real(kind=8),dimension(3) :: ggg
15286 !el local variables
15287       integer :: i,iint,j,k,iteli,itypj,subchap
15288       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15289       real(kind=8) :: evdw2,evdw2_14,evdwij
15290       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15291                     dist_temp, dist_init
15292
15293       evdw2=0.0D0
15294       evdw2_14=0.0d0
15295 !d    print '(a)','Enter ESCP'
15296 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15297       do i=iatscp_s,iatscp_e
15298         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15299         iteli=itel(i)
15300         xi=0.5D0*(c(1,i)+c(1,i+1))
15301         yi=0.5D0*(c(2,i)+c(2,i+1))
15302         zi=0.5D0*(c(3,i)+c(3,i+1))
15303           xi=mod(xi,boxxsize)
15304           if (xi.lt.0) xi=xi+boxxsize
15305           yi=mod(yi,boxysize)
15306           if (yi.lt.0) yi=yi+boxysize
15307           zi=mod(zi,boxzsize)
15308           if (zi.lt.0) zi=zi+boxzsize
15309
15310         do iint=1,nscp_gr(i)
15311
15312         do j=iscpstart(i,iint),iscpend(i,iint)
15313           itypj=itype(j,1)
15314           if (itypj.eq.ntyp1) cycle
15315 ! Uncomment following three lines for SC-p interactions
15316 !         xj=c(1,nres+j)-xi
15317 !         yj=c(2,nres+j)-yi
15318 !         zj=c(3,nres+j)-zi
15319 ! Uncomment following three lines for Ca-p interactions
15320 !          xj=c(1,j)-xi
15321 !          yj=c(2,j)-yi
15322 !          zj=c(3,j)-zi
15323           xj=c(1,j)
15324           yj=c(2,j)
15325           zj=c(3,j)
15326           xj=mod(xj,boxxsize)
15327           if (xj.lt.0) xj=xj+boxxsize
15328           yj=mod(yj,boxysize)
15329           if (yj.lt.0) yj=yj+boxysize
15330           zj=mod(zj,boxzsize)
15331           if (zj.lt.0) zj=zj+boxzsize
15332       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15333       xj_safe=xj
15334       yj_safe=yj
15335       zj_safe=zj
15336       subchap=0
15337       do xshift=-1,1
15338       do yshift=-1,1
15339       do zshift=-1,1
15340           xj=xj_safe+xshift*boxxsize
15341           yj=yj_safe+yshift*boxysize
15342           zj=zj_safe+zshift*boxzsize
15343           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15344           if(dist_temp.lt.dist_init) then
15345             dist_init=dist_temp
15346             xj_temp=xj
15347             yj_temp=yj
15348             zj_temp=zj
15349             subchap=1
15350           endif
15351        enddo
15352        enddo
15353        enddo
15354        if (subchap.eq.1) then
15355           xj=xj_temp-xi
15356           yj=yj_temp-yi
15357           zj=zj_temp-zi
15358        else
15359           xj=xj_safe-xi
15360           yj=yj_safe-yi
15361           zj=zj_safe-zi
15362        endif
15363
15364           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15365           rij=dsqrt(1.0d0/rrij)
15366             sss_ele_cut=sscale_ele(rij)
15367             sss_ele_grad=sscagrad_ele(rij)
15368 !            print *,sss_ele_cut,sss_ele_grad,&
15369 !            (rij),r_cut_ele,rlamb_ele
15370             if (sss_ele_cut.le.0.0) cycle
15371           sss=sscale(rij/rscp(itypj,iteli))
15372           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15373           if (sss.gt.0.0d0) then
15374
15375             fac=rrij**expon2
15376             e1=fac*fac*aad(itypj,iteli)
15377             e2=fac*bad(itypj,iteli)
15378             if (iabs(j-i) .le. 2) then
15379               e1=scal14*e1
15380               e2=scal14*e2
15381               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15382             endif
15383             evdwij=e1+e2
15384             evdw2=evdw2+evdwij*sss*sss_ele_cut
15385             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15386                 'evdw2',i,j,sss,evdwij
15387 !
15388 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15389 !
15390             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15391             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15392             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15393
15394             ggg(1)=xj*fac
15395             ggg(2)=yj*fac
15396             ggg(3)=zj*fac
15397 ! Uncomment following three lines for SC-p interactions
15398 !           do k=1,3
15399 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15400 !           enddo
15401 ! Uncomment following line for SC-p interactions
15402 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15403             do k=1,3
15404               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15405               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15406             enddo
15407           endif
15408         enddo
15409
15410         enddo ! iint
15411       enddo ! i
15412       do i=1,nct
15413         do j=1,3
15414           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15415           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15416           gradx_scp(j,i)=expon*gradx_scp(j,i)
15417         enddo
15418       enddo
15419 !******************************************************************************
15420 !
15421 !                              N O T E !!!
15422 !
15423 ! To save time the factor EXPON has been extracted from ALL components
15424 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15425 ! use!
15426 !
15427 !******************************************************************************
15428       return
15429       end subroutine escp_short
15430 !-----------------------------------------------------------------------------
15431 ! energy_p_new-sep_barrier.F
15432 !-----------------------------------------------------------------------------
15433       subroutine sc_grad_scale(scalfac)
15434 !      implicit real*8 (a-h,o-z)
15435       use calc_data
15436 !      include 'DIMENSIONS'
15437 !      include 'COMMON.CHAIN'
15438 !      include 'COMMON.DERIV'
15439 !      include 'COMMON.CALC'
15440 !      include 'COMMON.IOUNITS'
15441       real(kind=8),dimension(3) :: dcosom1,dcosom2
15442       real(kind=8) :: scalfac
15443 !el local variables
15444 !      integer :: i,j,k,l
15445
15446       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15447       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15448       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15449            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15450 ! diagnostics only
15451 !      eom1=0.0d0
15452 !      eom2=0.0d0
15453 !      eom12=evdwij*eps1_om12
15454 ! end diagnostics
15455 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15456 !     &  " sigder",sigder
15457 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15458 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15459       do k=1,3
15460         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15461         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15462       enddo
15463       do k=1,3
15464         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15465          *sss_ele_cut
15466       enddo
15467 !      write (iout,*) "gg",(gg(k),k=1,3)
15468       do k=1,3
15469         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15470                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15471                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15472                  *sss_ele_cut
15473         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15474                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15475                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15476          *sss_ele_cut
15477 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15478 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15479 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15480 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15481       enddo
15482 !
15483 ! Calculate the components of the gradient in DC and X
15484 !
15485       do l=1,3
15486         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15487         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15488       enddo
15489       return
15490       end subroutine sc_grad_scale
15491 !-----------------------------------------------------------------------------
15492 ! energy_split-sep.F
15493 !-----------------------------------------------------------------------------
15494       subroutine etotal_long(energia)
15495 !
15496 ! Compute the long-range slow-varying contributions to the energy
15497 !
15498 !      implicit real*8 (a-h,o-z)
15499 !      include 'DIMENSIONS'
15500       use MD_data, only: totT,usampl,eq_time
15501 #ifndef ISNAN
15502       external proc_proc
15503 #ifdef WINPGI
15504 !MS$ATTRIBUTES C ::  proc_proc
15505 #endif
15506 #endif
15507 #ifdef MPI
15508       include "mpif.h"
15509       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15510 #endif
15511 !      include 'COMMON.SETUP'
15512 !      include 'COMMON.IOUNITS'
15513 !      include 'COMMON.FFIELD'
15514 !      include 'COMMON.DERIV'
15515 !      include 'COMMON.INTERACT'
15516 !      include 'COMMON.SBRIDGE'
15517 !      include 'COMMON.CHAIN'
15518 !      include 'COMMON.VAR'
15519 !      include 'COMMON.LOCAL'
15520 !      include 'COMMON.MD'
15521       real(kind=8),dimension(0:n_ene) :: energia
15522 !el local variables
15523       integer :: i,n_corr,n_corr1,ierror,ierr
15524       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15525                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15526                   ecorr,ecorr5,ecorr6,eturn6,time00
15527 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15528 !elwrite(iout,*)"in etotal long"
15529
15530       if (modecalc.eq.12.or.modecalc.eq.14) then
15531 #ifdef MPI
15532 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15533 #else
15534         call int_from_cart1(.false.)
15535 #endif
15536       endif
15537 !elwrite(iout,*)"in etotal long"
15538
15539 #ifdef MPI
15540 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15541 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15542       call flush(iout)
15543       if (nfgtasks.gt.1) then
15544         time00=MPI_Wtime()
15545 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15546         if (fg_rank.eq.0) then
15547           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15548 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15549 !          call flush(iout)
15550 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15551 ! FG slaves as WEIGHTS array.
15552           weights_(1)=wsc
15553           weights_(2)=wscp
15554           weights_(3)=welec
15555           weights_(4)=wcorr
15556           weights_(5)=wcorr5
15557           weights_(6)=wcorr6
15558           weights_(7)=wel_loc
15559           weights_(8)=wturn3
15560           weights_(9)=wturn4
15561           weights_(10)=wturn6
15562           weights_(11)=wang
15563           weights_(12)=wscloc
15564           weights_(13)=wtor
15565           weights_(14)=wtor_d
15566           weights_(15)=wstrain
15567           weights_(16)=wvdwpp
15568           weights_(17)=wbond
15569           weights_(18)=scal14
15570           weights_(21)=wsccor
15571 ! FG Master broadcasts the WEIGHTS_ array
15572           call MPI_Bcast(weights_(1),n_ene,&
15573               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15574         else
15575 ! FG slaves receive the WEIGHTS array
15576           call MPI_Bcast(weights(1),n_ene,&
15577               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15578           wsc=weights(1)
15579           wscp=weights(2)
15580           welec=weights(3)
15581           wcorr=weights(4)
15582           wcorr5=weights(5)
15583           wcorr6=weights(6)
15584           wel_loc=weights(7)
15585           wturn3=weights(8)
15586           wturn4=weights(9)
15587           wturn6=weights(10)
15588           wang=weights(11)
15589           wscloc=weights(12)
15590           wtor=weights(13)
15591           wtor_d=weights(14)
15592           wstrain=weights(15)
15593           wvdwpp=weights(16)
15594           wbond=weights(17)
15595           scal14=weights(18)
15596           wsccor=weights(21)
15597         endif
15598         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15599           king,FG_COMM,IERR)
15600          time_Bcast=time_Bcast+MPI_Wtime()-time00
15601          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15602 !        call chainbuild_cart
15603 !        call int_from_cart1(.false.)
15604       endif
15605 !      write (iout,*) 'Processor',myrank,
15606 !     &  ' calling etotal_short ipot=',ipot
15607 !      call flush(iout)
15608 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15609 #endif
15610 !d    print *,'nnt=',nnt,' nct=',nct
15611 !
15612 !elwrite(iout,*)"in etotal long"
15613 ! Compute the side-chain and electrostatic interaction energy
15614 !
15615       goto (101,102,103,104,105,106) ipot
15616 ! Lennard-Jones potential.
15617   101 call elj_long(evdw)
15618 !d    print '(a)','Exit ELJ'
15619       goto 107
15620 ! Lennard-Jones-Kihara potential (shifted).
15621   102 call eljk_long(evdw)
15622       goto 107
15623 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15624   103 call ebp_long(evdw)
15625       goto 107
15626 ! Gay-Berne potential (shifted LJ, angular dependence).
15627   104 call egb_long(evdw)
15628       goto 107
15629 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15630   105 call egbv_long(evdw)
15631       goto 107
15632 ! Soft-sphere potential
15633   106 call e_softsphere(evdw)
15634 !
15635 ! Calculate electrostatic (H-bonding) energy of the main chain.
15636 !
15637   107 continue
15638       call vec_and_deriv
15639       if (ipot.lt.6) then
15640 #ifdef SPLITELE
15641          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15642              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15643              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15644              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15645 #else
15646          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15647              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15648              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15649              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15650 #endif
15651            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15652          else
15653             ees=0
15654             evdw1=0
15655             eel_loc=0
15656             eello_turn3=0
15657             eello_turn4=0
15658          endif
15659       else
15660 !        write (iout,*) "Soft-spheer ELEC potential"
15661         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15662          eello_turn4)
15663       endif
15664 !
15665 ! Calculate excluded-volume interaction energy between peptide groups
15666 ! and side chains.
15667 !
15668       if (ipot.lt.6) then
15669        if(wscp.gt.0d0) then
15670         call escp_long(evdw2,evdw2_14)
15671        else
15672         evdw2=0
15673         evdw2_14=0
15674        endif
15675       else
15676         call escp_soft_sphere(evdw2,evdw2_14)
15677       endif
15678 !
15679 ! 12/1/95 Multi-body terms
15680 !
15681       n_corr=0
15682       n_corr1=0
15683       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15684           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15685          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15686 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15687 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15688       else
15689          ecorr=0.0d0
15690          ecorr5=0.0d0
15691          ecorr6=0.0d0
15692          eturn6=0.0d0
15693       endif
15694       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15695          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15696       endif
15697 !
15698 ! If performing constraint dynamics, call the constraint energy
15699 !  after the equilibration time
15700       if(usampl.and.totT.gt.eq_time) then
15701          call EconstrQ
15702          call Econstr_back
15703       else
15704          Uconst=0.0d0
15705          Uconst_back=0.0d0
15706       endif
15707 !
15708 ! Sum the energies
15709 !
15710       do i=1,n_ene
15711         energia(i)=0.0d0
15712       enddo
15713       energia(1)=evdw
15714 #ifdef SCP14
15715       energia(2)=evdw2-evdw2_14
15716       energia(18)=evdw2_14
15717 #else
15718       energia(2)=evdw2
15719       energia(18)=0.0d0
15720 #endif
15721 #ifdef SPLITELE
15722       energia(3)=ees
15723       energia(16)=evdw1
15724 #else
15725       energia(3)=ees+evdw1
15726       energia(16)=0.0d0
15727 #endif
15728       energia(4)=ecorr
15729       energia(5)=ecorr5
15730       energia(6)=ecorr6
15731       energia(7)=eel_loc
15732       energia(8)=eello_turn3
15733       energia(9)=eello_turn4
15734       energia(10)=eturn6
15735       energia(20)=Uconst+Uconst_back
15736       call sum_energy(energia,.true.)
15737 !      write (iout,*) "Exit ETOTAL_LONG"
15738       call flush(iout)
15739       return
15740       end subroutine etotal_long
15741 !-----------------------------------------------------------------------------
15742       subroutine etotal_short(energia)
15743 !
15744 ! Compute the short-range fast-varying contributions to the energy
15745 !
15746 !      implicit real*8 (a-h,o-z)
15747 !      include 'DIMENSIONS'
15748 #ifndef ISNAN
15749       external proc_proc
15750 #ifdef WINPGI
15751 !MS$ATTRIBUTES C ::  proc_proc
15752 #endif
15753 #endif
15754 #ifdef MPI
15755       include "mpif.h"
15756       integer :: ierror,ierr
15757       real(kind=8),dimension(n_ene) :: weights_
15758       real(kind=8) :: time00
15759 #endif
15760 !      include 'COMMON.SETUP'
15761 !      include 'COMMON.IOUNITS'
15762 !      include 'COMMON.FFIELD'
15763 !      include 'COMMON.DERIV'
15764 !      include 'COMMON.INTERACT'
15765 !      include 'COMMON.SBRIDGE'
15766 !      include 'COMMON.CHAIN'
15767 !      include 'COMMON.VAR'
15768 !      include 'COMMON.LOCAL'
15769       real(kind=8),dimension(0:n_ene) :: energia
15770 !el local variables
15771       integer :: i,nres6
15772       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15773       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15774       nres6=6*nres
15775
15776 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15777 !      call flush(iout)
15778       if (modecalc.eq.12.or.modecalc.eq.14) then
15779 #ifdef MPI
15780         if (fg_rank.eq.0) call int_from_cart1(.false.)
15781 #else
15782         call int_from_cart1(.false.)
15783 #endif
15784       endif
15785 #ifdef MPI
15786 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15787 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15788 !      call flush(iout)
15789       if (nfgtasks.gt.1) then
15790         time00=MPI_Wtime()
15791 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15792         if (fg_rank.eq.0) then
15793           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15794 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15795 !          call flush(iout)
15796 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15797 ! FG slaves as WEIGHTS array.
15798           weights_(1)=wsc
15799           weights_(2)=wscp
15800           weights_(3)=welec
15801           weights_(4)=wcorr
15802           weights_(5)=wcorr5
15803           weights_(6)=wcorr6
15804           weights_(7)=wel_loc
15805           weights_(8)=wturn3
15806           weights_(9)=wturn4
15807           weights_(10)=wturn6
15808           weights_(11)=wang
15809           weights_(12)=wscloc
15810           weights_(13)=wtor
15811           weights_(14)=wtor_d
15812           weights_(15)=wstrain
15813           weights_(16)=wvdwpp
15814           weights_(17)=wbond
15815           weights_(18)=scal14
15816           weights_(21)=wsccor
15817 ! FG Master broadcasts the WEIGHTS_ array
15818           call MPI_Bcast(weights_(1),n_ene,&
15819               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15820         else
15821 ! FG slaves receive the WEIGHTS array
15822           call MPI_Bcast(weights(1),n_ene,&
15823               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15824           wsc=weights(1)
15825           wscp=weights(2)
15826           welec=weights(3)
15827           wcorr=weights(4)
15828           wcorr5=weights(5)
15829           wcorr6=weights(6)
15830           wel_loc=weights(7)
15831           wturn3=weights(8)
15832           wturn4=weights(9)
15833           wturn6=weights(10)
15834           wang=weights(11)
15835           wscloc=weights(12)
15836           wtor=weights(13)
15837           wtor_d=weights(14)
15838           wstrain=weights(15)
15839           wvdwpp=weights(16)
15840           wbond=weights(17)
15841           scal14=weights(18)
15842           wsccor=weights(21)
15843         endif
15844 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15845         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15846           king,FG_COMM,IERR)
15847 !        write (iout,*) "Processor",myrank," BROADCAST c"
15848         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15849           king,FG_COMM,IERR)
15850 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15851         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15852           king,FG_COMM,IERR)
15853 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15854         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15855           king,FG_COMM,IERR)
15856 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15857         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15858           king,FG_COMM,IERR)
15859 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15860         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15861           king,FG_COMM,IERR)
15862 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15863         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15864           king,FG_COMM,IERR)
15865 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15866         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15867           king,FG_COMM,IERR)
15868 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15869         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15870           king,FG_COMM,IERR)
15871          time_Bcast=time_Bcast+MPI_Wtime()-time00
15872 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15873       endif
15874 !      write (iout,*) 'Processor',myrank,
15875 !     &  ' calling etotal_short ipot=',ipot
15876 !      call flush(iout)
15877 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15878 #endif
15879 !      call int_from_cart1(.false.)
15880 !
15881 ! Compute the side-chain and electrostatic interaction energy
15882 !
15883       goto (101,102,103,104,105,106) ipot
15884 ! Lennard-Jones potential.
15885   101 call elj_short(evdw)
15886 !d    print '(a)','Exit ELJ'
15887       goto 107
15888 ! Lennard-Jones-Kihara potential (shifted).
15889   102 call eljk_short(evdw)
15890       goto 107
15891 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15892   103 call ebp_short(evdw)
15893       goto 107
15894 ! Gay-Berne potential (shifted LJ, angular dependence).
15895   104 call egb_short(evdw)
15896       goto 107
15897 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15898   105 call egbv_short(evdw)
15899       goto 107
15900 ! Soft-sphere potential - already dealt with in the long-range part
15901   106 evdw=0.0d0
15902 !  106 call e_softsphere_short(evdw)
15903 !
15904 ! Calculate electrostatic (H-bonding) energy of the main chain.
15905 !
15906   107 continue
15907 !
15908 ! Calculate the short-range part of Evdwpp
15909 !
15910       call evdwpp_short(evdw1)
15911 !
15912 ! Calculate the short-range part of ESCp
15913 !
15914       if (ipot.lt.6) then
15915         call escp_short(evdw2,evdw2_14)
15916       endif
15917 !
15918 ! Calculate the bond-stretching energy
15919 !
15920       call ebond(estr)
15921 !
15922 ! Calculate the disulfide-bridge and other energy and the contributions
15923 ! from other distance constraints.
15924       call edis(ehpb)
15925 !
15926 ! Calculate the virtual-bond-angle energy.
15927 !
15928       call ebend(ebe,ethetacnstr)
15929 !
15930 ! Calculate the SC local energy.
15931 !
15932       call vec_and_deriv
15933       call esc(escloc)
15934 !
15935 ! Calculate the virtual-bond torsional energy.
15936 !
15937       call etor(etors,edihcnstr)
15938 !
15939 ! 6/23/01 Calculate double-torsional energy
15940 !
15941       call etor_d(etors_d)
15942 !
15943 ! 21/5/07 Calculate local sicdechain correlation energy
15944 !
15945       if (wsccor.gt.0.0d0) then
15946         call eback_sc_corr(esccor)
15947       else
15948         esccor=0.0d0
15949       endif
15950 !
15951 ! Put energy components into an array
15952 !
15953       do i=1,n_ene
15954         energia(i)=0.0d0
15955       enddo
15956       energia(1)=evdw
15957 #ifdef SCP14
15958       energia(2)=evdw2-evdw2_14
15959       energia(18)=evdw2_14
15960 #else
15961       energia(2)=evdw2
15962       energia(18)=0.0d0
15963 #endif
15964 #ifdef SPLITELE
15965       energia(16)=evdw1
15966 #else
15967       energia(3)=evdw1
15968 #endif
15969       energia(11)=ebe
15970       energia(12)=escloc
15971       energia(13)=etors
15972       energia(14)=etors_d
15973       energia(15)=ehpb
15974       energia(17)=estr
15975       energia(19)=edihcnstr
15976       energia(21)=esccor
15977 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15978       call flush(iout)
15979       call sum_energy(energia,.true.)
15980 !      write (iout,*) "Exit ETOTAL_SHORT"
15981       call flush(iout)
15982       return
15983       end subroutine etotal_short
15984 !-----------------------------------------------------------------------------
15985 ! gnmr1.f
15986 !-----------------------------------------------------------------------------
15987       real(kind=8) function gnmr1(y,ymin,ymax)
15988 !      implicit none
15989       real(kind=8) :: y,ymin,ymax
15990       real(kind=8) :: wykl=4.0d0
15991       if (y.lt.ymin) then
15992         gnmr1=(ymin-y)**wykl/wykl
15993       else if (y.gt.ymax) then
15994         gnmr1=(y-ymax)**wykl/wykl
15995       else
15996         gnmr1=0.0d0
15997       endif
15998       return
15999       end function gnmr1
16000 !-----------------------------------------------------------------------------
16001       real(kind=8) function gnmr1prim(y,ymin,ymax)
16002 !      implicit none
16003       real(kind=8) :: y,ymin,ymax
16004       real(kind=8) :: wykl=4.0d0
16005       if (y.lt.ymin) then
16006         gnmr1prim=-(ymin-y)**(wykl-1)
16007       else if (y.gt.ymax) then
16008         gnmr1prim=(y-ymax)**(wykl-1)
16009       else
16010         gnmr1prim=0.0d0
16011       endif
16012       return
16013       end function gnmr1prim
16014 !----------------------------------------------------------------------------
16015       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16016       real(kind=8) y,ymin,ymax,sigma
16017       real(kind=8) wykl /4.0d0/
16018       if (y.lt.ymin) then
16019         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16020       else if (y.gt.ymax) then
16021         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16022       else
16023         rlornmr1=0.0d0
16024       endif
16025       return
16026       end function rlornmr1
16027 !------------------------------------------------------------------------------
16028       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16029       real(kind=8) y,ymin,ymax,sigma
16030       real(kind=8) wykl /4.0d0/
16031       if (y.lt.ymin) then
16032         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16033         ((ymin-y)**wykl+sigma**wykl)**2
16034       else if (y.gt.ymax) then
16035         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16036         ((y-ymax)**wykl+sigma**wykl)**2
16037       else
16038         rlornmr1prim=0.0d0
16039       endif
16040       return
16041       end function rlornmr1prim
16042
16043       real(kind=8) function harmonic(y,ymax)
16044 !      implicit none
16045       real(kind=8) :: y,ymax
16046       real(kind=8) :: wykl=2.0d0
16047       harmonic=(y-ymax)**wykl
16048       return
16049       end function harmonic
16050 !-----------------------------------------------------------------------------
16051       real(kind=8) function harmonicprim(y,ymax)
16052       real(kind=8) :: y,ymin,ymax
16053       real(kind=8) :: wykl=2.0d0
16054       harmonicprim=(y-ymax)*wykl
16055       return
16056       end function harmonicprim
16057 !-----------------------------------------------------------------------------
16058 ! gradient_p.F
16059 !-----------------------------------------------------------------------------
16060       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16061
16062       use io_base, only:intout,briefout
16063 !      implicit real*8 (a-h,o-z)
16064 !      include 'DIMENSIONS'
16065 !      include 'COMMON.CHAIN'
16066 !      include 'COMMON.DERIV'
16067 !      include 'COMMON.VAR'
16068 !      include 'COMMON.INTERACT'
16069 !      include 'COMMON.FFIELD'
16070 !      include 'COMMON.MD'
16071 !      include 'COMMON.IOUNITS'
16072       real(kind=8),external :: ufparm
16073       integer :: uiparm(1)
16074       real(kind=8) :: urparm(1)
16075       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16076       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16077       integer :: n,nf,ind,ind1,i,k,j
16078 !
16079 ! This subroutine calculates total internal coordinate gradient.
16080 ! Depending on the number of function evaluations, either whole energy
16081 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16082 ! internal coordinates are reevaluated or only the cartesian-in-internal
16083 ! coordinate derivatives are evaluated. The subroutine was designed to work
16084 ! with SUMSL.
16085 !
16086 !
16087       icg=mod(nf,2)+1
16088
16089 !d      print *,'grad',nf,icg
16090       if (nf-nfl+1) 20,30,40
16091    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16092 !    write (iout,*) 'grad 20'
16093       if (nf.eq.0) return
16094       goto 40
16095    30 call var_to_geom(n,x)
16096       call chainbuild
16097 !    write (iout,*) 'grad 30'
16098 !
16099 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16100 !
16101    40 call cartder
16102 !     write (iout,*) 'grad 40'
16103 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16104 !
16105 ! Convert the Cartesian gradient into internal-coordinate gradient.
16106 !
16107       ind=0
16108       ind1=0
16109       do i=1,nres-2
16110       gthetai=0.0D0
16111       gphii=0.0D0
16112       do j=i+1,nres-1
16113           ind=ind+1
16114 !         ind=indmat(i,j)
16115 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16116         do k=1,3
16117             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16118           enddo
16119         do k=1,3
16120           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16121           enddo
16122         enddo
16123       do j=i+1,nres-1
16124           ind1=ind1+1
16125 !         ind1=indmat(i,j)
16126 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16127         do k=1,3
16128           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16129           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16130           enddo
16131         enddo
16132       if (i.gt.1) g(i-1)=gphii
16133       if (n.gt.nphi) g(nphi+i)=gthetai
16134       enddo
16135       if (n.le.nphi+ntheta) goto 10
16136       do i=2,nres-1
16137       if (itype(i,1).ne.10) then
16138           galphai=0.0D0
16139         gomegai=0.0D0
16140         do k=1,3
16141           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16142           enddo
16143         do k=1,3
16144           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16145           enddo
16146           g(ialph(i,1))=galphai
16147         g(ialph(i,1)+nside)=gomegai
16148         endif
16149       enddo
16150 !
16151 ! Add the components corresponding to local energy terms.
16152 !
16153    10 continue
16154       do i=1,nvar
16155 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16156         g(i)=g(i)+gloc(i,icg)
16157       enddo
16158 ! Uncomment following three lines for diagnostics.
16159 !d    call intout
16160 !elwrite(iout,*) "in gradient after calling intout"
16161 !d    call briefout(0,0.0d0)
16162 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16163       return
16164       end subroutine gradient
16165 !-----------------------------------------------------------------------------
16166       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16167
16168       use comm_chu
16169 !      implicit real*8 (a-h,o-z)
16170 !      include 'DIMENSIONS'
16171 !      include 'COMMON.DERIV'
16172 !      include 'COMMON.IOUNITS'
16173 !      include 'COMMON.GEO'
16174       integer :: n,nf
16175 !el      integer :: jjj
16176 !el      common /chuju/ jjj
16177       real(kind=8) :: energia(0:n_ene)
16178       integer :: uiparm(1)
16179       real(kind=8) :: urparm(1)
16180       real(kind=8) :: f
16181       real(kind=8),external :: ufparm
16182       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16183 !     if (jjj.gt.0) then
16184 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16185 !     endif
16186       nfl=nf
16187       icg=mod(nf,2)+1
16188 !d      print *,'func',nf,nfl,icg
16189       call var_to_geom(n,x)
16190       call zerograd
16191       call chainbuild
16192 !d    write (iout,*) 'ETOTAL called from FUNC'
16193       call etotal(energia)
16194       call sum_gradient
16195       f=energia(0)
16196 !     if (jjj.gt.0) then
16197 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16198 !       write (iout,*) 'f=',etot
16199 !       jjj=0
16200 !     endif
16201       return
16202       end subroutine func
16203 !-----------------------------------------------------------------------------
16204       subroutine cartgrad
16205 !      implicit real*8 (a-h,o-z)
16206 !      include 'DIMENSIONS'
16207       use energy_data
16208       use MD_data, only: totT,usampl,eq_time
16209 #ifdef MPI
16210       include 'mpif.h'
16211 #endif
16212 !      include 'COMMON.CHAIN'
16213 !      include 'COMMON.DERIV'
16214 !      include 'COMMON.VAR'
16215 !      include 'COMMON.INTERACT'
16216 !      include 'COMMON.FFIELD'
16217 !      include 'COMMON.MD'
16218 !      include 'COMMON.IOUNITS'
16219 !      include 'COMMON.TIME1'
16220 !
16221       integer :: i,j
16222
16223 ! This subrouting calculates total Cartesian coordinate gradient.
16224 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16225 !
16226 !el#define DEBUG
16227 #ifdef TIMING
16228       time00=MPI_Wtime()
16229 #endif
16230       icg=1
16231       call sum_gradient
16232 #ifdef TIMING
16233 #endif
16234 !el      write (iout,*) "After sum_gradient"
16235 #ifdef DEBUG
16236 !el      write (iout,*) "After sum_gradient"
16237       do i=1,nres-1
16238         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16239         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16240       enddo
16241 #endif
16242 ! If performing constraint dynamics, add the gradients of the constraint energy
16243       if(usampl.and.totT.gt.eq_time) then
16244          do i=1,nct
16245            do j=1,3
16246              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16247              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16248            enddo
16249          enddo
16250          do i=1,nres-3
16251            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16252          enddo
16253          do i=1,nres-2
16254            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16255          enddo
16256       endif
16257 !elwrite (iout,*) "After sum_gradient"
16258 #ifdef TIMING
16259       time01=MPI_Wtime()
16260 #endif
16261       call intcartderiv
16262 !elwrite (iout,*) "After sum_gradient"
16263 #ifdef TIMING
16264       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16265 #endif
16266 !     call checkintcartgrad
16267 !     write(iout,*) 'calling int_to_cart'
16268 #ifdef DEBUG
16269       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16270 #endif
16271       do i=0,nct
16272         do j=1,3
16273           gcart(j,i)=gradc(j,i,icg)
16274           gxcart(j,i)=gradx(j,i,icg)
16275 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16276         enddo
16277 #ifdef DEBUG
16278         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16279           (gxcart(j,i),j=1,3),gloc(i,icg)
16280 #endif
16281       enddo
16282 #ifdef TIMING
16283       time01=MPI_Wtime()
16284 #endif
16285 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16286       call int_to_cart
16287 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16288
16289 #ifdef TIMING
16290             time_inttocart=time_inttocart+MPI_Wtime()-time01
16291 #endif
16292 #ifdef DEBUG
16293             write (iout,*) "gcart and gxcart after int_to_cart"
16294             do i=0,nres-1
16295             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16296                 (gxcart(j,i),j=1,3)
16297             enddo
16298 #endif
16299 #ifdef CARGRAD
16300 #ifdef DEBUG
16301             write (iout,*) "CARGRAD"
16302 #endif
16303             do i=nres,0,-1
16304             do j=1,3
16305               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16306       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16307             enddo
16308       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16309       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16310             enddo
16311       ! Correction: dummy residues
16312             if (nnt.gt.1) then
16313               do j=1,3
16314       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16315                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16316               enddo
16317             endif
16318             if (nct.lt.nres) then
16319               do j=1,3
16320       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16321                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16322               enddo
16323             endif
16324 #endif
16325 #ifdef TIMING
16326             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16327 #endif
16328       !el#undef DEBUG
16329             return
16330             end subroutine cartgrad
16331       !-----------------------------------------------------------------------------
16332             subroutine zerograd
16333       !      implicit real*8 (a-h,o-z)
16334       !      include 'DIMENSIONS'
16335       !      include 'COMMON.DERIV'
16336       !      include 'COMMON.CHAIN'
16337       !      include 'COMMON.VAR'
16338       !      include 'COMMON.MD'
16339       !      include 'COMMON.SCCOR'
16340       !
16341       !el local variables
16342             integer :: i,j,intertyp,k
16343       ! Initialize Cartesian-coordinate gradient
16344       !
16345       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16346       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16347
16348       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16349       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16350       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16351       !      allocate(gradcorr_long(3,nres))
16352       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16353       !      allocate(gcorr6_turn_long(3,nres))
16354       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16355
16356       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16357
16358       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16359       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16360
16361       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16362       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16363
16364       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16365       !      allocate(gscloc(3,nres)) !(3,maxres)
16366       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16367
16368
16369
16370       !      common /deriv_scloc/
16371       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16372       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16373       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16374       !      common /mpgrad/
16375       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16376
16377
16378
16379       !          gradc(j,i,icg)=0.0d0
16380       !          gradx(j,i,icg)=0.0d0
16381
16382       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16383       !elwrite(iout,*) "icg",icg
16384             do i=-1,nres
16385             do j=1,3
16386               gvdwx(j,i)=0.0D0
16387               gradx_scp(j,i)=0.0D0
16388               gvdwc(j,i)=0.0D0
16389               gvdwc_scp(j,i)=0.0D0
16390               gvdwc_scpp(j,i)=0.0d0
16391               gelc(j,i)=0.0D0
16392               gelc_long(j,i)=0.0D0
16393               gradb(j,i)=0.0d0
16394               gradbx(j,i)=0.0d0
16395               gvdwpp(j,i)=0.0d0
16396               gel_loc(j,i)=0.0d0
16397               gel_loc_long(j,i)=0.0d0
16398               ghpbc(j,i)=0.0D0
16399               ghpbx(j,i)=0.0D0
16400               gcorr3_turn(j,i)=0.0d0
16401               gcorr4_turn(j,i)=0.0d0
16402               gradcorr(j,i)=0.0d0
16403               gradcorr_long(j,i)=0.0d0
16404               gradcorr5_long(j,i)=0.0d0
16405               gradcorr6_long(j,i)=0.0d0
16406               gcorr6_turn_long(j,i)=0.0d0
16407               gradcorr5(j,i)=0.0d0
16408               gradcorr6(j,i)=0.0d0
16409               gcorr6_turn(j,i)=0.0d0
16410               gsccorc(j,i)=0.0d0
16411               gsccorx(j,i)=0.0d0
16412               gradc(j,i,icg)=0.0d0
16413               gradx(j,i,icg)=0.0d0
16414               gscloc(j,i)=0.0d0
16415               gsclocx(j,i)=0.0d0
16416               gliptran(j,i)=0.0d0
16417               gliptranx(j,i)=0.0d0
16418               gliptranc(j,i)=0.0d0
16419               gshieldx(j,i)=0.0d0
16420               gshieldc(j,i)=0.0d0
16421               gshieldc_loc(j,i)=0.0d0
16422               gshieldx_ec(j,i)=0.0d0
16423               gshieldc_ec(j,i)=0.0d0
16424               gshieldc_loc_ec(j,i)=0.0d0
16425               gshieldx_t3(j,i)=0.0d0
16426               gshieldc_t3(j,i)=0.0d0
16427               gshieldc_loc_t3(j,i)=0.0d0
16428               gshieldx_t4(j,i)=0.0d0
16429               gshieldc_t4(j,i)=0.0d0
16430               gshieldc_loc_t4(j,i)=0.0d0
16431               gshieldx_ll(j,i)=0.0d0
16432               gshieldc_ll(j,i)=0.0d0
16433               gshieldc_loc_ll(j,i)=0.0d0
16434               gg_tube(j,i)=0.0d0
16435               gg_tube_sc(j,i)=0.0d0
16436               gradafm(j,i)=0.0d0
16437               gradb_nucl(j,i)=0.0d0
16438               gradbx_nucl(j,i)=0.0d0
16439               gvdwpp_nucl(j,i)=0.0d0
16440               gvdwpp(j,i)=0.0d0
16441               gelpp(j,i)=0.0d0
16442               gvdwpsb(j,i)=0.0d0
16443               gvdwpsb1(j,i)=0.0d0
16444               gvdwsbc(j,i)=0.0d0
16445               gvdwsbx(j,i)=0.0d0
16446               gelsbc(j,i)=0.0d0
16447               gradcorr_nucl(j,i)=0.0d0
16448               gradcorr3_nucl(j,i)=0.0d0
16449               gradxorr_nucl(j,i)=0.0d0
16450               gradxorr3_nucl(j,i)=0.0d0
16451               gelsbx(j,i)=0.0d0
16452               gsbloc(j,i)=0.0d0
16453               gsblocx(j,i)=0.0d0
16454               gradpepcat(j,i)=0.0d0
16455               gradpepcatx(j,i)=0.0d0
16456               gradcatcat(j,i)=0.0d0
16457               gvdwx_scbase(j,i)=0.0d0
16458               gvdwc_scbase(j,i)=0.0d0
16459               gvdwx_pepbase(j,i)=0.0d0
16460               gvdwc_pepbase(j,i)=0.0d0
16461               gvdwx_scpho(j,i)=0.0d0
16462               gvdwc_scpho(j,i)=0.0d0
16463               gvdwc_peppho(j,i)=0.0d0
16464             enddo
16465              enddo
16466             do i=0,nres
16467             do j=1,3
16468               do intertyp=1,3
16469                gloc_sc(intertyp,i,icg)=0.0d0
16470               enddo
16471             enddo
16472             enddo
16473             do i=1,nres
16474              do j=1,maxcontsshi
16475              shield_list(j,i)=0
16476             do k=1,3
16477       !C           print *,i,j,k
16478                grad_shield_side(k,j,i)=0.0d0
16479                grad_shield_loc(k,j,i)=0.0d0
16480              enddo
16481              enddo
16482              ishield_list(i)=0
16483             enddo
16484
16485       !
16486       ! Initialize the gradient of local energy terms.
16487       !
16488       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16489       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16490       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16491       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16492       !      allocate(gel_loc_turn3(nres))
16493       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16494       !      allocate(gsccor_loc(nres))      !(maxres)
16495
16496             do i=1,4*nres
16497             gloc(i,icg)=0.0D0
16498             enddo
16499             do i=1,nres
16500             gel_loc_loc(i)=0.0d0
16501             gcorr_loc(i)=0.0d0
16502             g_corr5_loc(i)=0.0d0
16503             g_corr6_loc(i)=0.0d0
16504             gel_loc_turn3(i)=0.0d0
16505             gel_loc_turn4(i)=0.0d0
16506             gel_loc_turn6(i)=0.0d0
16507             gsccor_loc(i)=0.0d0
16508             enddo
16509       ! initialize gcart and gxcart
16510       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16511             do i=0,nres
16512             do j=1,3
16513               gcart(j,i)=0.0d0
16514               gxcart(j,i)=0.0d0
16515             enddo
16516             enddo
16517             return
16518             end subroutine zerograd
16519       !-----------------------------------------------------------------------------
16520             real(kind=8) function fdum()
16521             fdum=0.0D0
16522             return
16523             end function fdum
16524       !-----------------------------------------------------------------------------
16525       ! intcartderiv.F
16526       !-----------------------------------------------------------------------------
16527             subroutine intcartderiv
16528       !      implicit real*8 (a-h,o-z)
16529       !      include 'DIMENSIONS'
16530 #ifdef MPI
16531             include 'mpif.h'
16532 #endif
16533       !      include 'COMMON.SETUP'
16534       !      include 'COMMON.CHAIN'
16535       !      include 'COMMON.VAR'
16536       !      include 'COMMON.GEO'
16537       !      include 'COMMON.INTERACT'
16538       !      include 'COMMON.DERIV'
16539       !      include 'COMMON.IOUNITS'
16540       !      include 'COMMON.LOCAL'
16541       !      include 'COMMON.SCCOR'
16542             real(kind=8) :: pi4,pi34
16543             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16544             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16545                       dcosomega,dsinomega !(3,3,maxres)
16546             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16547
16548             integer :: i,j,k
16549             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16550                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16551                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16552                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16553             integer :: nres2
16554             nres2=2*nres
16555
16556       !el from module energy-------------
16557       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16558       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16559       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16560
16561       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16562       !el      allocate(dsintau(3,3,3,0:nres2))
16563       !el      allocate(dtauangle(3,3,3,0:nres2))
16564       !el      allocate(domicron(3,2,2,0:nres2))
16565       !el      allocate(dcosomicron(3,2,2,0:nres2))
16566
16567
16568
16569 #if defined(MPI) && defined(PARINTDER)
16570             if (nfgtasks.gt.1 .and. me.eq.king) &
16571             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16572 #endif
16573             pi4 = 0.5d0*pipol
16574             pi34 = 3*pi4
16575
16576       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16577       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16578
16579       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16580             do i=1,nres
16581             do j=1,3
16582               dtheta(j,1,i)=0.0d0
16583               dtheta(j,2,i)=0.0d0
16584               dphi(j,1,i)=0.0d0
16585               dphi(j,2,i)=0.0d0
16586               dphi(j,3,i)=0.0d0
16587             enddo
16588             enddo
16589       ! Derivatives of theta's
16590 #if defined(MPI) && defined(PARINTDER)
16591       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16592             do i=max0(ithet_start-1,3),ithet_end
16593 #else
16594             do i=3,nres
16595 #endif
16596             cost=dcos(theta(i))
16597             sint=sqrt(1-cost*cost)
16598             do j=1,3
16599               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16600               vbld(i-1)
16601               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16602               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16603               vbld(i)
16604               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16605             enddo
16606             enddo
16607 #if defined(MPI) && defined(PARINTDER)
16608       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16609             do i=max0(ithet_start-1,3),ithet_end
16610 #else
16611             do i=3,nres
16612 #endif
16613             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16614             cost1=dcos(omicron(1,i))
16615             sint1=sqrt(1-cost1*cost1)
16616             cost2=dcos(omicron(2,i))
16617             sint2=sqrt(1-cost2*cost2)
16618              do j=1,3
16619       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16620               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16621               cost1*dc_norm(j,i-2))/ &
16622               vbld(i-1)
16623               domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16624               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16625               +cost1*(dc_norm(j,i-1+nres)))/ &
16626               vbld(i-1+nres)
16627               domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16628       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16629       !C Looks messy but better than if in loop
16630               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16631               +cost2*dc_norm(j,i-1))/ &
16632               vbld(i)
16633               domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16634               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16635                +cost2*(-dc_norm(j,i-1+nres)))/ &
16636               vbld(i-1+nres)
16637       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16638               domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16639             enddo
16640              endif
16641             enddo
16642       !elwrite(iout,*) "after vbld write"
16643       ! Derivatives of phi:
16644       ! If phi is 0 or 180 degrees, then the formulas
16645       ! have to be derived by power series expansion of the
16646       ! conventional formulas around 0 and 180.
16647 #ifdef PARINTDER
16648             do i=iphi1_start,iphi1_end
16649 #else
16650             do i=4,nres
16651 #endif
16652       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16653       ! the conventional case
16654             sint=dsin(theta(i))
16655             sint1=dsin(theta(i-1))
16656             sing=dsin(phi(i))
16657             cost=dcos(theta(i))
16658             cost1=dcos(theta(i-1))
16659             cosg=dcos(phi(i))
16660             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16661             fac0=1.0d0/(sint1*sint)
16662             fac1=cost*fac0
16663             fac2=cost1*fac0
16664             fac3=cosg*cost1/(sint1*sint1)
16665             fac4=cosg*cost/(sint*sint)
16666       !    Obtaining the gamma derivatives from sine derivative
16667              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16668                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16669                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16670              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16671              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16672              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16673              do j=1,3
16674                 ctgt=cost/sint
16675                 ctgt1=cost1/sint1
16676                 cosg_inv=1.0d0/cosg
16677                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16678                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16679                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16680                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16681                 dsinphi(j,2,i)= &
16682                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16683                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16684                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16685                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16686                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16687       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16688                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16689                 endif
16690       ! Bug fixed 3/24/05 (AL)
16691              enddo
16692       !   Obtaining the gamma derivatives from cosine derivative
16693             else
16694                do j=1,3
16695                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16696                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16697                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16698                dc_norm(j,i-3))/vbld(i-2)
16699                dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16700                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16701                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16702                dcostheta(j,1,i)
16703                dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16704                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16705                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16706                dc_norm(j,i-1))/vbld(i)
16707                dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16708                endif
16709              enddo
16710             endif
16711             enddo
16712       !alculate derivative of Tauangle
16713 #ifdef PARINTDER
16714             do i=itau_start,itau_end
16715 #else
16716             do i=3,nres
16717       !elwrite(iout,*) " vecpr",i,nres
16718 #endif
16719              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16720       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16721       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16722       !c dtauangle(j,intertyp,dervityp,residue number)
16723       !c INTERTYP=1 SC...Ca...Ca..Ca
16724       ! the conventional case
16725             sint=dsin(theta(i))
16726             sint1=dsin(omicron(2,i-1))
16727             sing=dsin(tauangle(1,i))
16728             cost=dcos(theta(i))
16729             cost1=dcos(omicron(2,i-1))
16730             cosg=dcos(tauangle(1,i))
16731       !elwrite(iout,*) " vecpr5",i,nres
16732             do j=1,3
16733       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16734       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16735             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16736       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16737             enddo
16738             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16739             fac0=1.0d0/(sint1*sint)
16740             fac1=cost*fac0
16741             fac2=cost1*fac0
16742             fac3=cosg*cost1/(sint1*sint1)
16743             fac4=cosg*cost/(sint*sint)
16744       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16745       !    Obtaining the gamma derivatives from sine derivative
16746              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16747                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16748                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16749              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16750              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16751              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16752             do j=1,3
16753                 ctgt=cost/sint
16754                 ctgt1=cost1/sint1
16755                 cosg_inv=1.0d0/cosg
16756                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16757              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16758              *vbld_inv(i-2+nres)
16759                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16760                 dsintau(j,1,2,i)= &
16761                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16762                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16763       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16764                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16765       ! Bug fixed 3/24/05 (AL)
16766                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16767                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16768       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16769                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16770              enddo
16771       !   Obtaining the gamma derivatives from cosine derivative
16772             else
16773                do j=1,3
16774                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16775                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16776                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16777                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16778                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16779                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16780                dcostheta(j,1,i)
16781                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16782                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16783                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16784                dc_norm(j,i-1))/vbld(i)
16785                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16786       !         write (iout,*) "else",i
16787              enddo
16788             endif
16789       !        do k=1,3
16790       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16791       !        enddo
16792             enddo
16793       !C Second case Ca...Ca...Ca...SC
16794 #ifdef PARINTDER
16795             do i=itau_start,itau_end
16796 #else
16797             do i=4,nres
16798 #endif
16799              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16800               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16801       ! the conventional case
16802             sint=dsin(omicron(1,i))
16803             sint1=dsin(theta(i-1))
16804             sing=dsin(tauangle(2,i))
16805             cost=dcos(omicron(1,i))
16806             cost1=dcos(theta(i-1))
16807             cosg=dcos(tauangle(2,i))
16808       !        do j=1,3
16809       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16810       !        enddo
16811             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16812             fac0=1.0d0/(sint1*sint)
16813             fac1=cost*fac0
16814             fac2=cost1*fac0
16815             fac3=cosg*cost1/(sint1*sint1)
16816             fac4=cosg*cost/(sint*sint)
16817       !    Obtaining the gamma derivatives from sine derivative
16818              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16819                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16820                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16821              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16822              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16823              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16824             do j=1,3
16825                 ctgt=cost/sint
16826                 ctgt1=cost1/sint1
16827                 cosg_inv=1.0d0/cosg
16828                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16829                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16830       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16831       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16832                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16833                 dsintau(j,2,2,i)= &
16834                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16835                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16836       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16837       !     & sing*ctgt*domicron(j,1,2,i),
16838       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16839                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16840       ! Bug fixed 3/24/05 (AL)
16841                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16842                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16843       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16844                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16845              enddo
16846       !   Obtaining the gamma derivatives from cosine derivative
16847             else
16848                do j=1,3
16849                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16850                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16851                dc_norm(j,i-3))/vbld(i-2)
16852                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16853                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16854                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16855                dcosomicron(j,1,1,i)
16856                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16857                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16858                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16859                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16860                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16861       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16862              enddo
16863             endif
16864             enddo
16865
16866       !CC third case SC...Ca...Ca...SC
16867 #ifdef PARINTDER
16868
16869             do i=itau_start,itau_end
16870 #else
16871             do i=3,nres
16872 #endif
16873       ! the conventional case
16874             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16875             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16876             sint=dsin(omicron(1,i))
16877             sint1=dsin(omicron(2,i-1))
16878             sing=dsin(tauangle(3,i))
16879             cost=dcos(omicron(1,i))
16880             cost1=dcos(omicron(2,i-1))
16881             cosg=dcos(tauangle(3,i))
16882             do j=1,3
16883             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16884       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16885             enddo
16886             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16887             fac0=1.0d0/(sint1*sint)
16888             fac1=cost*fac0
16889             fac2=cost1*fac0
16890             fac3=cosg*cost1/(sint1*sint1)
16891             fac4=cosg*cost/(sint*sint)
16892       !    Obtaining the gamma derivatives from sine derivative
16893              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16894                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16895                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16896              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16897              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16898              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16899             do j=1,3
16900                 ctgt=cost/sint
16901                 ctgt1=cost1/sint1
16902                 cosg_inv=1.0d0/cosg
16903                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16904                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16905                   *vbld_inv(i-2+nres)
16906                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16907                 dsintau(j,3,2,i)= &
16908                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16909                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16910                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16911       ! Bug fixed 3/24/05 (AL)
16912                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16913                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16914                   *vbld_inv(i-1+nres)
16915       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16916                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16917              enddo
16918       !   Obtaining the gamma derivatives from cosine derivative
16919             else
16920                do j=1,3
16921                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16922                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16923                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16924                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16925                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16926                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16927                dcosomicron(j,1,1,i)
16928                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16929                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16930                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16931                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16932                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16933       !          write(iout,*) "else",i
16934              enddo
16935             endif
16936             enddo
16937
16938 #ifdef CRYST_SC
16939       !   Derivatives of side-chain angles alpha and omega
16940 #if defined(MPI) && defined(PARINTDER)
16941             do i=ibond_start,ibond_end
16942 #else
16943             do i=2,nres-1
16944 #endif
16945               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16946                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16947                  fac6=fac5/vbld(i)
16948                  fac7=fac5*fac5
16949                  fac8=fac5/vbld(i+1)
16950                  fac9=fac5/vbld(i+nres)
16951                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16952                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16953                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16954                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16955                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16956                  sina=sqrt(1-cosa*cosa)
16957                  sino=dsin(omeg(i))
16958       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16959                  do j=1,3
16960                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16961                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16962                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16963                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16964                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16965                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16966                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16967                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16968                   vbld(i+nres))
16969                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16970                 enddo
16971       ! obtaining the derivatives of omega from sines
16972                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16973                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16974                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16975                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16976                    dsin(theta(i+1)))
16977                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16978                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16979                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16980                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16981                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16982                    coso_inv=1.0d0/dcos(omeg(i))
16983                    do j=1,3
16984                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16985                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16986                    (sino*dc_norm(j,i-1))/vbld(i)
16987                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16988                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16989                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16990                    -sino*dc_norm(j,i)/vbld(i+1)
16991                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16992                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16993                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16994                    vbld(i+nres)
16995                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16996                   enddo
16997                else
16998       !   obtaining the derivatives of omega from cosines
16999                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17000                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17001                  fac12=fac10*sina
17002                  fac13=fac12*fac12
17003                  fac14=sina*sina
17004                  do j=1,3
17005                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17006                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17007                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17008                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17009                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17010                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17011                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17012                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17013                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17014                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17015                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17016                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17017                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17018                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17019                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17020                 enddo
17021               endif
17022              else
17023                do j=1,3
17024                  do k=1,3
17025                    dalpha(k,j,i)=0.0d0
17026                    domega(k,j,i)=0.0d0
17027                  enddo
17028                enddo
17029              endif
17030              enddo
17031 #endif
17032 #if defined(MPI) && defined(PARINTDER)
17033             if (nfgtasks.gt.1) then
17034 #ifdef DEBUG
17035       !d      write (iout,*) "Gather dtheta"
17036       !d      call flush(iout)
17037             write (iout,*) "dtheta before gather"
17038             do i=1,nres
17039             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17040             enddo
17041 #endif
17042             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17043             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17044             king,FG_COMM,IERROR)
17045 #ifdef DEBUG
17046       !d      write (iout,*) "Gather dphi"
17047       !d      call flush(iout)
17048             write (iout,*) "dphi before gather"
17049             do i=1,nres
17050             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17051             enddo
17052 #endif
17053             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17054             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17055             king,FG_COMM,IERROR)
17056       !d      write (iout,*) "Gather dalpha"
17057       !d      call flush(iout)
17058 #ifdef CRYST_SC
17059             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17060             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17061             king,FG_COMM,IERROR)
17062       !d      write (iout,*) "Gather domega"
17063       !d      call flush(iout)
17064             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17065             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17066             king,FG_COMM,IERROR)
17067 #endif
17068             endif
17069 #endif
17070 #ifdef DEBUG
17071             write (iout,*) "dtheta after gather"
17072             do i=1,nres
17073             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17074             enddo
17075             write (iout,*) "dphi after gather"
17076             do i=1,nres
17077             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17078             enddo
17079             write (iout,*) "dalpha after gather"
17080             do i=1,nres
17081             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17082             enddo
17083             write (iout,*) "domega after gather"
17084             do i=1,nres
17085             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17086             enddo
17087 #endif
17088             return
17089             end subroutine intcartderiv
17090       !-----------------------------------------------------------------------------
17091             subroutine checkintcartgrad
17092       !      implicit real*8 (a-h,o-z)
17093       !      include 'DIMENSIONS'
17094 #ifdef MPI
17095             include 'mpif.h'
17096 #endif
17097       !      include 'COMMON.CHAIN'
17098       !      include 'COMMON.VAR'
17099       !      include 'COMMON.GEO'
17100       !      include 'COMMON.INTERACT'
17101       !      include 'COMMON.DERIV'
17102       !      include 'COMMON.IOUNITS'
17103       !      include 'COMMON.SETUP'
17104             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17105             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17106             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17107             real(kind=8),dimension(3) :: dc_norm_s
17108             real(kind=8) :: aincr=1.0d-5
17109             integer :: i,j
17110             real(kind=8) :: dcji
17111             do i=1,nres
17112             phi_s(i)=phi(i)
17113             theta_s(i)=theta(i)
17114             alph_s(i)=alph(i)
17115             omeg_s(i)=omeg(i)
17116             enddo
17117       ! Check theta gradient
17118             write (iout,*) &
17119              "Analytical (upper) and numerical (lower) gradient of theta"
17120             write (iout,*)
17121             do i=3,nres
17122             do j=1,3
17123               dcji=dc(j,i-2)
17124               dc(j,i-2)=dcji+aincr
17125               call chainbuild_cart
17126               call int_from_cart1(.false.)
17127           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17128           dc(j,i-2)=dcji
17129           dcji=dc(j,i-1)
17130           dc(j,i-1)=dc(j,i-1)+aincr
17131           call chainbuild_cart
17132           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17133           dc(j,i-1)=dcji
17134         enddo
17135 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17136 !el          (dtheta(j,2,i),j=1,3)
17137 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17138 !el          (dthetanum(j,2,i),j=1,3)
17139 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17140 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17141 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17142 !el        write (iout,*)
17143       enddo
17144 ! Check gamma gradient
17145       write (iout,*) &
17146        "Analytical (upper) and numerical (lower) gradient of gamma"
17147       do i=4,nres
17148         do j=1,3
17149           dcji=dc(j,i-3)
17150           dc(j,i-3)=dcji+aincr
17151           call chainbuild_cart
17152           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17153               dc(j,i-3)=dcji
17154           dcji=dc(j,i-2)
17155           dc(j,i-2)=dcji+aincr
17156           call chainbuild_cart
17157           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17158           dc(j,i-2)=dcji
17159           dcji=dc(j,i-1)
17160           dc(j,i-1)=dc(j,i-1)+aincr
17161           call chainbuild_cart
17162           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17163           dc(j,i-1)=dcji
17164         enddo
17165 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17166 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17167 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17168 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17169 !el        write (iout,'(5x,3(3f10.5,5x))') &
17170 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17171 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17172 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17173 !el        write (iout,*)
17174       enddo
17175 ! Check alpha gradient
17176       write (iout,*) &
17177        "Analytical (upper) and numerical (lower) gradient of alpha"
17178       do i=2,nres-1
17179        if(itype(i,1).ne.10) then
17180                  do j=1,3
17181                   dcji=dc(j,i-1)
17182                    dc(j,i-1)=dcji+aincr
17183               call chainbuild_cart
17184               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17185                  /aincr
17186                   dc(j,i-1)=dcji
17187               dcji=dc(j,i)
17188               dc(j,i)=dcji+aincr
17189               call chainbuild_cart
17190               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17191                  /aincr
17192               dc(j,i)=dcji
17193               dcji=dc(j,i+nres)
17194               dc(j,i+nres)=dc(j,i+nres)+aincr
17195               call chainbuild_cart
17196               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17197                  /aincr
17198              dc(j,i+nres)=dcji
17199             enddo
17200           endif
17201 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17202 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17203 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17204 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17205 !el        write (iout,'(5x,3(3f10.5,5x))') &
17206 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17207 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17208 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17209 !el        write (iout,*)
17210       enddo
17211 !     Check omega gradient
17212       write (iout,*) &
17213        "Analytical (upper) and numerical (lower) gradient of omega"
17214       do i=2,nres-1
17215        if(itype(i,1).ne.10) then
17216                  do j=1,3
17217                   dcji=dc(j,i-1)
17218                    dc(j,i-1)=dcji+aincr
17219               call chainbuild_cart
17220               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17221                  /aincr
17222                   dc(j,i-1)=dcji
17223               dcji=dc(j,i)
17224               dc(j,i)=dcji+aincr
17225               call chainbuild_cart
17226               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17227                  /aincr
17228               dc(j,i)=dcji
17229               dcji=dc(j,i+nres)
17230               dc(j,i+nres)=dc(j,i+nres)+aincr
17231               call chainbuild_cart
17232               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17233                  /aincr
17234              dc(j,i+nres)=dcji
17235             enddo
17236           endif
17237 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17238 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17239 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17240 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17241 !el        write (iout,'(5x,3(3f10.5,5x))') &
17242 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17243 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17244 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17245 !el        write (iout,*)
17246       enddo
17247       return
17248       end subroutine checkintcartgrad
17249 !-----------------------------------------------------------------------------
17250 ! q_measure.F
17251 !-----------------------------------------------------------------------------
17252       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17253 !      implicit real*8 (a-h,o-z)
17254 !      include 'DIMENSIONS'
17255 !      include 'COMMON.IOUNITS'
17256 !      include 'COMMON.CHAIN'
17257 !      include 'COMMON.INTERACT'
17258 !      include 'COMMON.VAR'
17259       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17260       integer :: kkk,nsep=3
17261       real(kind=8) :: qm      !dist,
17262       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17263       logical :: lprn=.false.
17264       logical :: flag
17265 !      real(kind=8) :: sigm,x
17266
17267 !el      sigm(x)=0.25d0*x     ! local function
17268       qqmax=1.0d10
17269       do kkk=1,nperm
17270       qq = 0.0d0
17271       nl=0
17272        if(flag) then
17273         do il=seg1+nsep,seg2
17274           do jl=seg1,il-nsep
17275             nl=nl+1
17276             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17277                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17278                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17279             dij=dist(il,jl)
17280             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17281             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17282               nl=nl+1
17283               d0ijCM=dsqrt( &
17284                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17285                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17286                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17287               dijCM=dist(il+nres,jl+nres)
17288               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17289             endif
17290             qq = qq+qqij+qqijCM
17291           enddo
17292         enddo
17293         qq = qq/nl
17294       else
17295       do il=seg1,seg2
17296         if((seg3-il).lt.3) then
17297              secseg=il+3
17298         else
17299              secseg=seg3
17300         endif
17301           do jl=secseg,seg4
17302             nl=nl+1
17303             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17304                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17305                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17306             dij=dist(il,jl)
17307             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17308             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17309               nl=nl+1
17310               d0ijCM=dsqrt( &
17311                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17312                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17313                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17314               dijCM=dist(il+nres,jl+nres)
17315               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17316             endif
17317             qq = qq+qqij+qqijCM
17318           enddo
17319         enddo
17320       qq = qq/nl
17321       endif
17322       if (qqmax.le.qq) qqmax=qq
17323       enddo
17324       qwolynes=1.0d0-qqmax
17325       return
17326       end function qwolynes
17327 !-----------------------------------------------------------------------------
17328       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17329 !      implicit real*8 (a-h,o-z)
17330 !      include 'DIMENSIONS'
17331 !      include 'COMMON.IOUNITS'
17332 !      include 'COMMON.CHAIN'
17333 !      include 'COMMON.INTERACT'
17334 !      include 'COMMON.VAR'
17335 !      include 'COMMON.MD'
17336       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17337       integer :: nsep=3, kkk
17338 !el      real(kind=8) :: dist
17339       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17340       logical :: lprn=.false.
17341       logical :: flag
17342       real(kind=8) :: sim,dd0,fac,ddqij
17343 !el      sigm(x)=0.25d0*x           ! local function
17344       do kkk=1,nperm
17345       do i=0,nres
17346         do j=1,3
17347           dqwol(j,i)=0.0d0
17348           dxqwol(j,i)=0.0d0
17349         enddo
17350       enddo
17351       nl=0
17352        if(flag) then
17353         do il=seg1+nsep,seg2
17354           do jl=seg1,il-nsep
17355             nl=nl+1
17356             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17357                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17358                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17359             dij=dist(il,jl)
17360             sim = 1.0d0/sigm(d0ij)
17361             sim = sim*sim
17362             dd0 = dij-d0ij
17363             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17364           do k=1,3
17365               ddqij = (c(k,il)-c(k,jl))*fac
17366               dqwol(k,il)=dqwol(k,il)+ddqij
17367               dqwol(k,jl)=dqwol(k,jl)-ddqij
17368             enddo
17369
17370             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17371               nl=nl+1
17372               d0ijCM=dsqrt( &
17373                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17374                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17375                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17376               dijCM=dist(il+nres,jl+nres)
17377               sim = 1.0d0/sigm(d0ijCM)
17378               sim = sim*sim
17379               dd0=dijCM-d0ijCM
17380               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17381               do k=1,3
17382                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17383                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17384                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17385               enddo
17386             endif
17387           enddo
17388         enddo
17389        else
17390         do il=seg1,seg2
17391         if((seg3-il).lt.3) then
17392              secseg=il+3
17393         else
17394              secseg=seg3
17395         endif
17396           do jl=secseg,seg4
17397             nl=nl+1
17398             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17399                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17400                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17401             dij=dist(il,jl)
17402             sim = 1.0d0/sigm(d0ij)
17403             sim = sim*sim
17404             dd0 = dij-d0ij
17405             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17406             do k=1,3
17407               ddqij = (c(k,il)-c(k,jl))*fac
17408               dqwol(k,il)=dqwol(k,il)+ddqij
17409               dqwol(k,jl)=dqwol(k,jl)-ddqij
17410             enddo
17411             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17412               nl=nl+1
17413               d0ijCM=dsqrt( &
17414                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17415                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17416                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17417               dijCM=dist(il+nres,jl+nres)
17418               sim = 1.0d0/sigm(d0ijCM)
17419               sim=sim*sim
17420               dd0 = dijCM-d0ijCM
17421               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17422               do k=1,3
17423                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17424                dxqwol(k,il)=dxqwol(k,il)+ddqij
17425                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17426               enddo
17427             endif
17428           enddo
17429         enddo
17430       endif
17431       enddo
17432        do i=0,nres
17433          do j=1,3
17434            dqwol(j,i)=dqwol(j,i)/nl
17435            dxqwol(j,i)=dxqwol(j,i)/nl
17436          enddo
17437        enddo
17438       return
17439       end subroutine qwolynes_prim
17440 !-----------------------------------------------------------------------------
17441       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17442 !      implicit real*8 (a-h,o-z)
17443 !      include 'DIMENSIONS'
17444 !      include 'COMMON.IOUNITS'
17445 !      include 'COMMON.CHAIN'
17446 !      include 'COMMON.INTERACT'
17447 !      include 'COMMON.VAR'
17448       integer :: seg1,seg2,seg3,seg4
17449       logical :: flag
17450       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17451       real(kind=8),dimension(3,0:2*nres) :: cdummy
17452       real(kind=8) :: q1,q2
17453       real(kind=8) :: delta=1.0d-10
17454       integer :: i,j
17455
17456       do i=0,nres
17457         do j=1,3
17458           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17459           cdummy(j,i)=c(j,i)
17460           c(j,i)=c(j,i)+delta
17461           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17462           qwolan(j,i)=(q2-q1)/delta
17463           c(j,i)=cdummy(j,i)
17464         enddo
17465       enddo
17466       do i=0,nres
17467         do j=1,3
17468           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17469           cdummy(j,i+nres)=c(j,i+nres)
17470           c(j,i+nres)=c(j,i+nres)+delta
17471           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17472           qwolxan(j,i)=(q2-q1)/delta
17473           c(j,i+nres)=cdummy(j,i+nres)
17474         enddo
17475       enddo
17476 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17477 !      do i=0,nct
17478 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17479 !      enddo
17480 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17481 !      do i=0,nct
17482 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17483 !      enddo
17484       return
17485       end subroutine qwol_num
17486 !-----------------------------------------------------------------------------
17487       subroutine EconstrQ
17488 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17489 !      implicit real*8 (a-h,o-z)
17490 !      include 'DIMENSIONS'
17491 !      include 'COMMON.CONTROL'
17492 !      include 'COMMON.VAR'
17493 !      include 'COMMON.MD'
17494       use MD_data
17495 !#ifndef LANG0
17496 !      include 'COMMON.LANGEVIN'
17497 !#else
17498 !      include 'COMMON.LANGEVIN.lang0'
17499 !#endif
17500 !      include 'COMMON.CHAIN'
17501 !      include 'COMMON.DERIV'
17502 !      include 'COMMON.GEO'
17503 !      include 'COMMON.LOCAL'
17504 !      include 'COMMON.INTERACT'
17505 !      include 'COMMON.IOUNITS'
17506 !      include 'COMMON.NAMES'
17507 !      include 'COMMON.TIME1'
17508       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17509       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17510                    duconst,duxconst
17511       integer :: kstart,kend,lstart,lend,idummy
17512       real(kind=8) :: delta=1.0d-7
17513       integer :: i,j,k,ii
17514       do i=0,nres
17515          do j=1,3
17516             duconst(j,i)=0.0d0
17517             dudconst(j,i)=0.0d0
17518             duxconst(j,i)=0.0d0
17519             dudxconst(j,i)=0.0d0
17520          enddo
17521       enddo
17522       Uconst=0.0d0
17523       do i=1,nfrag
17524          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17525            idummy,idummy)
17526          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17527 ! Calculating the derivatives of Constraint energy with respect to Q
17528          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17529            qinfrag(i,iset))
17530 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17531 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17532 !         hmnum=(hm2-hm1)/delta
17533 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17534 !     &   qinfrag(i,iset))
17535 !         write(iout,*) "harmonicnum frag", hmnum
17536 ! Calculating the derivatives of Q with respect to cartesian coordinates
17537          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17538           idummy,idummy)
17539 !         write(iout,*) "dqwol "
17540 !         do ii=1,nres
17541 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17542 !         enddo
17543 !         write(iout,*) "dxqwol "
17544 !         do ii=1,nres
17545 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17546 !         enddo
17547 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17548 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17549 !     &  ,idummy,idummy)
17550 !  The gradients of Uconst in Cs
17551          do ii=0,nres
17552             do j=1,3
17553                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17554                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17555             enddo
17556          enddo
17557       enddo
17558       do i=1,npair
17559          kstart=ifrag(1,ipair(1,i,iset),iset)
17560          kend=ifrag(2,ipair(1,i,iset),iset)
17561          lstart=ifrag(1,ipair(2,i,iset),iset)
17562          lend=ifrag(2,ipair(2,i,iset),iset)
17563          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17564          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17565 !  Calculating dU/dQ
17566          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17567 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17568 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17569 !         hmnum=(hm2-hm1)/delta
17570 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17571 !     &   qinpair(i,iset))
17572 !         write(iout,*) "harmonicnum pair ", hmnum
17573 ! Calculating dQ/dXi
17574          call qwolynes_prim(kstart,kend,.false.,&
17575           lstart,lend)
17576 !         write(iout,*) "dqwol "
17577 !         do ii=1,nres
17578 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17579 !         enddo
17580 !         write(iout,*) "dxqwol "
17581 !         do ii=1,nres
17582 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17583 !        enddo
17584 ! Calculating numerical gradients
17585 !        call qwol_num(kstart,kend,.false.
17586 !     &  ,lstart,lend)
17587 ! The gradients of Uconst in Cs
17588          do ii=0,nres
17589             do j=1,3
17590                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17591                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17592             enddo
17593          enddo
17594       enddo
17595 !      write(iout,*) "Uconst inside subroutine ", Uconst
17596 ! Transforming the gradients from Cs to dCs for the backbone
17597       do i=0,nres
17598          do j=i+1,nres
17599            do k=1,3
17600              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17601            enddo
17602          enddo
17603       enddo
17604 !  Transforming the gradients from Cs to dCs for the side chains
17605       do i=1,nres
17606          do j=1,3
17607            dudxconst(j,i)=duxconst(j,i)
17608          enddo
17609       enddo
17610 !      write(iout,*) "dU/ddc backbone "
17611 !       do ii=0,nres
17612 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17613 !      enddo
17614 !      write(iout,*) "dU/ddX side chain "
17615 !      do ii=1,nres
17616 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17617 !      enddo
17618 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17619 !      call dEconstrQ_num
17620       return
17621       end subroutine EconstrQ
17622 !-----------------------------------------------------------------------------
17623       subroutine dEconstrQ_num
17624 ! Calculating numerical dUconst/ddc and dUconst/ddx
17625 !      implicit real*8 (a-h,o-z)
17626 !      include 'DIMENSIONS'
17627 !      include 'COMMON.CONTROL'
17628 !      include 'COMMON.VAR'
17629 !      include 'COMMON.MD'
17630       use MD_data
17631 !#ifndef LANG0
17632 !      include 'COMMON.LANGEVIN'
17633 !#else
17634 !      include 'COMMON.LANGEVIN.lang0'
17635 !#endif
17636 !      include 'COMMON.CHAIN'
17637 !      include 'COMMON.DERIV'
17638 !      include 'COMMON.GEO'
17639 !      include 'COMMON.LOCAL'
17640 !      include 'COMMON.INTERACT'
17641 !      include 'COMMON.IOUNITS'
17642 !      include 'COMMON.NAMES'
17643 !      include 'COMMON.TIME1'
17644       real(kind=8) :: uzap1,uzap2
17645       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17646       integer :: kstart,kend,lstart,lend,idummy
17647       real(kind=8) :: delta=1.0d-7
17648 !el local variables
17649       integer :: i,ii,j
17650 !     real(kind=8) ::
17651 !     For the backbone
17652       do i=0,nres-1
17653          do j=1,3
17654             dUcartan(j,i)=0.0d0
17655             cdummy(j,i)=dc(j,i)
17656             dc(j,i)=dc(j,i)+delta
17657             call chainbuild_cart
17658           uzap2=0.0d0
17659             do ii=1,nfrag
17660              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17661                 idummy,idummy)
17662                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17663                 qinfrag(ii,iset))
17664             enddo
17665             do ii=1,npair
17666                kstart=ifrag(1,ipair(1,ii,iset),iset)
17667                kend=ifrag(2,ipair(1,ii,iset),iset)
17668                lstart=ifrag(1,ipair(2,ii,iset),iset)
17669                lend=ifrag(2,ipair(2,ii,iset),iset)
17670                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17671                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17672                  qinpair(ii,iset))
17673             enddo
17674             dc(j,i)=cdummy(j,i)
17675             call chainbuild_cart
17676             uzap1=0.0d0
17677              do ii=1,nfrag
17678              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17679                 idummy,idummy)
17680                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17681                 qinfrag(ii,iset))
17682             enddo
17683             do ii=1,npair
17684                kstart=ifrag(1,ipair(1,ii,iset),iset)
17685                kend=ifrag(2,ipair(1,ii,iset),iset)
17686                lstart=ifrag(1,ipair(2,ii,iset),iset)
17687                lend=ifrag(2,ipair(2,ii,iset),iset)
17688                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17689                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17690                 qinpair(ii,iset))
17691             enddo
17692             ducartan(j,i)=(uzap2-uzap1)/(delta)
17693          enddo
17694       enddo
17695 ! Calculating numerical gradients for dU/ddx
17696       do i=0,nres-1
17697          duxcartan(j,i)=0.0d0
17698          do j=1,3
17699             cdummy(j,i)=dc(j,i+nres)
17700             dc(j,i+nres)=dc(j,i+nres)+delta
17701             call chainbuild_cart
17702           uzap2=0.0d0
17703             do ii=1,nfrag
17704              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17705                 idummy,idummy)
17706                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17707                 qinfrag(ii,iset))
17708             enddo
17709             do ii=1,npair
17710                kstart=ifrag(1,ipair(1,ii,iset),iset)
17711                kend=ifrag(2,ipair(1,ii,iset),iset)
17712                lstart=ifrag(1,ipair(2,ii,iset),iset)
17713                lend=ifrag(2,ipair(2,ii,iset),iset)
17714                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17715                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17716                 qinpair(ii,iset))
17717             enddo
17718             dc(j,i+nres)=cdummy(j,i)
17719             call chainbuild_cart
17720             uzap1=0.0d0
17721              do ii=1,nfrag
17722                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17723                 ifrag(2,ii,iset),.true.,idummy,idummy)
17724                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17725                 qinfrag(ii,iset))
17726             enddo
17727             do ii=1,npair
17728                kstart=ifrag(1,ipair(1,ii,iset),iset)
17729                kend=ifrag(2,ipair(1,ii,iset),iset)
17730                lstart=ifrag(1,ipair(2,ii,iset),iset)
17731                lend=ifrag(2,ipair(2,ii,iset),iset)
17732                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17733                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17734                 qinpair(ii,iset))
17735             enddo
17736             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17737          enddo
17738       enddo
17739       write(iout,*) "Numerical dUconst/ddc backbone "
17740       do ii=0,nres
17741         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17742       enddo
17743 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17744 !      do ii=1,nres
17745 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17746 !      enddo
17747       return
17748       end subroutine dEconstrQ_num
17749 !-----------------------------------------------------------------------------
17750 ! ssMD.F
17751 !-----------------------------------------------------------------------------
17752       subroutine check_energies
17753
17754 !      use random, only: ran_number
17755
17756 !      implicit none
17757 !     Includes
17758 !      include 'DIMENSIONS'
17759 !      include 'COMMON.CHAIN'
17760 !      include 'COMMON.VAR'
17761 !      include 'COMMON.IOUNITS'
17762 !      include 'COMMON.SBRIDGE'
17763 !      include 'COMMON.LOCAL'
17764 !      include 'COMMON.GEO'
17765
17766 !     External functions
17767 !EL      double precision ran_number
17768 !EL      external ran_number
17769
17770 !     Local variables
17771       integer :: i,j,k,l,lmax,p,pmax
17772       real(kind=8) :: rmin,rmax
17773       real(kind=8) :: eij
17774
17775       real(kind=8) :: d
17776       real(kind=8) :: wi,rij,tj,pj
17777 !      return
17778
17779       i=5
17780       j=14
17781
17782       d=dsc(1)
17783       rmin=2.0D0
17784       rmax=12.0D0
17785
17786       lmax=10000
17787       pmax=1
17788
17789       do k=1,3
17790         c(k,i)=0.0D0
17791         c(k,j)=0.0D0
17792         c(k,nres+i)=0.0D0
17793         c(k,nres+j)=0.0D0
17794       enddo
17795
17796       do l=1,lmax
17797
17798 !t        wi=ran_number(0.0D0,pi)
17799 !        wi=ran_number(0.0D0,pi/6.0D0)
17800 !        wi=0.0D0
17801 !t        tj=ran_number(0.0D0,pi)
17802 !t        pj=ran_number(0.0D0,pi)
17803 !        pj=ran_number(0.0D0,pi/6.0D0)
17804 !        pj=0.0D0
17805
17806         do p=1,pmax
17807 !t           rij=ran_number(rmin,rmax)
17808
17809            c(1,j)=d*sin(pj)*cos(tj)
17810            c(2,j)=d*sin(pj)*sin(tj)
17811            c(3,j)=d*cos(pj)
17812
17813            c(3,nres+i)=-rij
17814
17815            c(1,i)=d*sin(wi)
17816            c(3,i)=-rij-d*cos(wi)
17817
17818            do k=1,3
17819               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17820               dc_norm(k,nres+i)=dc(k,nres+i)/d
17821               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17822               dc_norm(k,nres+j)=dc(k,nres+j)/d
17823            enddo
17824
17825            call dyn_ssbond_ene(i,j,eij)
17826         enddo
17827       enddo
17828       call exit(1)
17829       return
17830       end subroutine check_energies
17831 !-----------------------------------------------------------------------------
17832       subroutine dyn_ssbond_ene(resi,resj,eij)
17833 !      implicit none
17834 !      Includes
17835       use calc_data
17836       use comm_sschecks
17837 !      include 'DIMENSIONS'
17838 !      include 'COMMON.SBRIDGE'
17839 !      include 'COMMON.CHAIN'
17840 !      include 'COMMON.DERIV'
17841 !      include 'COMMON.LOCAL'
17842 !      include 'COMMON.INTERACT'
17843 !      include 'COMMON.VAR'
17844 !      include 'COMMON.IOUNITS'
17845 !      include 'COMMON.CALC'
17846 #ifndef CLUST
17847 #ifndef WHAM
17848        use MD_data
17849 !      include 'COMMON.MD'
17850 !      use MD, only: totT,t_bath
17851 #endif
17852 #endif
17853 !     External functions
17854 !EL      double precision h_base
17855 !EL      external h_base
17856
17857 !     Input arguments
17858       integer :: resi,resj
17859
17860 !     Output arguments
17861       real(kind=8) :: eij
17862
17863 !     Local variables
17864       logical :: havebond
17865       integer itypi,itypj
17866       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17867       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17868       real(kind=8),dimension(3) :: dcosom1,dcosom2
17869       real(kind=8) :: ed
17870       real(kind=8) :: pom1,pom2
17871       real(kind=8) :: ljA,ljB,ljXs
17872       real(kind=8),dimension(1:3) :: d_ljB
17873       real(kind=8) :: ssA,ssB,ssC,ssXs
17874       real(kind=8) :: ssxm,ljxm,ssm,ljm
17875       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17876       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17877       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17878 !-------FIRST METHOD
17879       real(kind=8) :: xm
17880       real(kind=8),dimension(1:3) :: d_xm
17881 !-------END FIRST METHOD
17882 !-------SECOND METHOD
17883 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17884 !-------END SECOND METHOD
17885
17886 !-------TESTING CODE
17887 !el      logical :: checkstop,transgrad
17888 !el      common /sschecks/ checkstop,transgrad
17889
17890       integer :: icheck,nicheck,jcheck,njcheck
17891       real(kind=8),dimension(-1:1) :: echeck
17892       real(kind=8) :: deps,ssx0,ljx0
17893 !-------END TESTING CODE
17894
17895       eij=0.0d0
17896       i=resi
17897       j=resj
17898
17899 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17900 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17901
17902       itypi=itype(i,1)
17903       dxi=dc_norm(1,nres+i)
17904       dyi=dc_norm(2,nres+i)
17905       dzi=dc_norm(3,nres+i)
17906       dsci_inv=vbld_inv(i+nres)
17907
17908       itypj=itype(j,1)
17909       xj=c(1,nres+j)-c(1,nres+i)
17910       yj=c(2,nres+j)-c(2,nres+i)
17911       zj=c(3,nres+j)-c(3,nres+i)
17912       dxj=dc_norm(1,nres+j)
17913       dyj=dc_norm(2,nres+j)
17914       dzj=dc_norm(3,nres+j)
17915       dscj_inv=vbld_inv(j+nres)
17916
17917       chi1=chi(itypi,itypj)
17918       chi2=chi(itypj,itypi)
17919       chi12=chi1*chi2
17920       chip1=chip(itypi)
17921       chip2=chip(itypj)
17922       chip12=chip1*chip2
17923       alf1=alp(itypi)
17924       alf2=alp(itypj)
17925       alf12=0.5D0*(alf1+alf2)
17926
17927       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17928       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17929 !     The following are set in sc_angular
17930 !      erij(1)=xj*rij
17931 !      erij(2)=yj*rij
17932 !      erij(3)=zj*rij
17933 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17934 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17935 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17936       call sc_angular
17937       rij=1.0D0/rij  ! Reset this so it makes sense
17938
17939       sig0ij=sigma(itypi,itypj)
17940       sig=sig0ij*dsqrt(1.0D0/sigsq)
17941
17942       ljXs=sig-sig0ij
17943       ljA=eps1*eps2rt**2*eps3rt**2
17944       ljB=ljA*bb_aq(itypi,itypj)
17945       ljA=ljA*aa_aq(itypi,itypj)
17946       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17947
17948       ssXs=d0cm
17949       deltat1=1.0d0-om1
17950       deltat2=1.0d0+om2
17951       deltat12=om2-om1+2.0d0
17952       cosphi=om12-om1*om2
17953       ssA=akcm
17954       ssB=akct*deltat12
17955       ssC=ss_depth &
17956            +akth*(deltat1*deltat1+deltat2*deltat2) &
17957            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17958       ssxm=ssXs-0.5D0*ssB/ssA
17959
17960 !-------TESTING CODE
17961 !$$$c     Some extra output
17962 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17963 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17964 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17965 !$$$      if (ssx0.gt.0.0d0) then
17966 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17967 !$$$      else
17968 !$$$        ssx0=ssxm
17969 !$$$      endif
17970 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17971 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17972 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17973 !$$$      return
17974 !-------END TESTING CODE
17975
17976 !-------TESTING CODE
17977 !     Stop and plot energy and derivative as a function of distance
17978       if (checkstop) then
17979         ssm=ssC-0.25D0*ssB*ssB/ssA
17980         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17981         if (ssm.lt.ljm .and. &
17982              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17983           nicheck=1000
17984           njcheck=1
17985           deps=0.5d-7
17986         else
17987           checkstop=.false.
17988         endif
17989       endif
17990       if (.not.checkstop) then
17991         nicheck=0
17992         njcheck=-1
17993       endif
17994
17995       do icheck=0,nicheck
17996       do jcheck=-1,njcheck
17997       if (checkstop) rij=(ssxm-1.0d0)+ &
17998              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17999 !-------END TESTING CODE
18000
18001       if (rij.gt.ljxm) then
18002         havebond=.false.
18003         ljd=rij-ljXs
18004         fac=(1.0D0/ljd)**expon
18005         e1=fac*fac*aa_aq(itypi,itypj)
18006         e2=fac*bb_aq(itypi,itypj)
18007         eij=eps1*eps2rt*eps3rt*(e1+e2)
18008         eps2der=eij*eps3rt
18009         eps3der=eij*eps2rt
18010         eij=eij*eps2rt*eps3rt
18011
18012         sigder=-sig/sigsq
18013         e1=e1*eps1*eps2rt**2*eps3rt**2
18014         ed=-expon*(e1+eij)/ljd
18015         sigder=ed*sigder
18016         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18017         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18018         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18019              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18020       else if (rij.lt.ssxm) then
18021         havebond=.true.
18022         ssd=rij-ssXs
18023         eij=ssA*ssd*ssd+ssB*ssd+ssC
18024
18025         ed=2*akcm*ssd+akct*deltat12
18026         pom1=akct*ssd
18027         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18028         eom1=-2*akth*deltat1-pom1-om2*pom2
18029         eom2= 2*akth*deltat2+pom1-om1*pom2
18030         eom12=pom2
18031       else
18032         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18033
18034         d_ssxm(1)=0.5D0*akct/ssA
18035         d_ssxm(2)=-d_ssxm(1)
18036         d_ssxm(3)=0.0D0
18037
18038         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18039         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18040         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18041         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18042
18043 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18044         xm=0.5d0*(ssxm+ljxm)
18045         do k=1,3
18046           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18047         enddo
18048         if (rij.lt.xm) then
18049           havebond=.true.
18050           ssm=ssC-0.25D0*ssB*ssB/ssA
18051           d_ssm(1)=0.5D0*akct*ssB/ssA
18052           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18053           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18054           d_ssm(3)=omega
18055           f1=(rij-xm)/(ssxm-xm)
18056           f2=(rij-ssxm)/(xm-ssxm)
18057           h1=h_base(f1,hd1)
18058           h2=h_base(f2,hd2)
18059           eij=ssm*h1+Ht*h2
18060           delta_inv=1.0d0/(xm-ssxm)
18061           deltasq_inv=delta_inv*delta_inv
18062           fac=ssm*hd1-Ht*hd2
18063           fac1=deltasq_inv*fac*(xm-rij)
18064           fac2=deltasq_inv*fac*(rij-ssxm)
18065           ed=delta_inv*(Ht*hd2-ssm*hd1)
18066           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18067           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18068           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18069         else
18070           havebond=.false.
18071           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18072           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18073           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18074           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18075                alf12/eps3rt)
18076           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18077           f1=(rij-ljxm)/(xm-ljxm)
18078           f2=(rij-xm)/(ljxm-xm)
18079           h1=h_base(f1,hd1)
18080           h2=h_base(f2,hd2)
18081           eij=Ht*h1+ljm*h2
18082           delta_inv=1.0d0/(ljxm-xm)
18083           deltasq_inv=delta_inv*delta_inv
18084           fac=Ht*hd1-ljm*hd2
18085           fac1=deltasq_inv*fac*(ljxm-rij)
18086           fac2=deltasq_inv*fac*(rij-xm)
18087           ed=delta_inv*(ljm*hd2-Ht*hd1)
18088           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18089           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18090           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18091         endif
18092 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18093
18094 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18095 !$$$        ssd=rij-ssXs
18096 !$$$        ljd=rij-ljXs
18097 !$$$        fac1=rij-ljxm
18098 !$$$        fac2=rij-ssxm
18099 !$$$
18100 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18101 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18102 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18103 !$$$
18104 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18105 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18106 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18107 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18108 !$$$        d_ssm(3)=omega
18109 !$$$
18110 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18111 !$$$        do k=1,3
18112 !$$$          d_ljm(k)=ljm*d_ljB(k)
18113 !$$$        enddo
18114 !$$$        ljm=ljm*ljB
18115 !$$$
18116 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18117 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18118 !$$$        d_ss(2)=akct*ssd
18119 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18120 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18121 !$$$        d_ss(3)=omega
18122 !$$$
18123 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18124 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18125 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18126 !$$$        do k=1,3
18127 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18128 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18129 !$$$        enddo
18130 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18131 !$$$
18132 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18133 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18134 !$$$        h1=h_base(f1,hd1)
18135 !$$$        h2=h_base(f2,hd2)
18136 !$$$        eij=ss*h1+ljf*h2
18137 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18138 !$$$        deltasq_inv=delta_inv*delta_inv
18139 !$$$        fac=ljf*hd2-ss*hd1
18140 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18141 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18142 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18143 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18144 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18145 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18146 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18147 !$$$
18148 !$$$        havebond=.false.
18149 !$$$        if (ed.gt.0.0d0) havebond=.true.
18150 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18151
18152       endif
18153
18154       if (havebond) then
18155 !#ifndef CLUST
18156 !#ifndef WHAM
18157 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18158 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18159 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18160 !        endif
18161 !#endif
18162 !#endif
18163         dyn_ssbond_ij(i,j)=eij
18164       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18165         dyn_ssbond_ij(i,j)=1.0d300
18166 !#ifndef CLUST
18167 !#ifndef WHAM
18168 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18169 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18170 !#endif
18171 !#endif
18172       endif
18173
18174 !-------TESTING CODE
18175 !el      if (checkstop) then
18176         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18177              "CHECKSTOP",rij,eij,ed
18178         echeck(jcheck)=eij
18179 !el      endif
18180       enddo
18181       if (checkstop) then
18182         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18183       endif
18184       enddo
18185       if (checkstop) then
18186         transgrad=.true.
18187         checkstop=.false.
18188       endif
18189 !-------END TESTING CODE
18190
18191       do k=1,3
18192         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18193         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18194       enddo
18195       do k=1,3
18196         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18197       enddo
18198       do k=1,3
18199         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18200              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18201              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18202         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18203              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18204              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18205       enddo
18206 !grad      do k=i,j-1
18207 !grad        do l=1,3
18208 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18209 !grad        enddo
18210 !grad      enddo
18211
18212       do l=1,3
18213         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18214         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18215       enddo
18216
18217       return
18218       end subroutine dyn_ssbond_ene
18219 !--------------------------------------------------------------------------
18220          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18221 !      implicit none
18222 !      Includes
18223       use calc_data
18224       use comm_sschecks
18225 !      include 'DIMENSIONS'
18226 !      include 'COMMON.SBRIDGE'
18227 !      include 'COMMON.CHAIN'
18228 !      include 'COMMON.DERIV'
18229 !      include 'COMMON.LOCAL'
18230 !      include 'COMMON.INTERACT'
18231 !      include 'COMMON.VAR'
18232 !      include 'COMMON.IOUNITS'
18233 !      include 'COMMON.CALC'
18234 #ifndef CLUST
18235 #ifndef WHAM
18236        use MD_data
18237 !      include 'COMMON.MD'
18238 !      use MD, only: totT,t_bath
18239 #endif
18240 #endif
18241       double precision h_base
18242       external h_base
18243
18244 !c     Input arguments
18245       integer resi,resj,resk,m,itypi,itypj,itypk
18246
18247 !c     Output arguments
18248       double precision eij,eij1,eij2,eij3
18249
18250 !c     Local variables
18251       logical havebond
18252 !c      integer itypi,itypj,k,l
18253       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18254       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18255       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18256       double precision sig0ij,ljd,sig,fac,e1,e2
18257       double precision dcosom1(3),dcosom2(3),ed
18258       double precision pom1,pom2
18259       double precision ljA,ljB,ljXs
18260       double precision d_ljB(1:3)
18261       double precision ssA,ssB,ssC,ssXs
18262       double precision ssxm,ljxm,ssm,ljm
18263       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18264       eij=0.0
18265       if (dtriss.eq.0) return
18266       i=resi
18267       j=resj
18268       k=resk
18269 !C      write(iout,*) resi,resj,resk
18270       itypi=itype(i,1)
18271       dxi=dc_norm(1,nres+i)
18272       dyi=dc_norm(2,nres+i)
18273       dzi=dc_norm(3,nres+i)
18274       dsci_inv=vbld_inv(i+nres)
18275       xi=c(1,nres+i)
18276       yi=c(2,nres+i)
18277       zi=c(3,nres+i)
18278       itypj=itype(j,1)
18279       xj=c(1,nres+j)
18280       yj=c(2,nres+j)
18281       zj=c(3,nres+j)
18282
18283       dxj=dc_norm(1,nres+j)
18284       dyj=dc_norm(2,nres+j)
18285       dzj=dc_norm(3,nres+j)
18286       dscj_inv=vbld_inv(j+nres)
18287       itypk=itype(k,1)
18288       xk=c(1,nres+k)
18289       yk=c(2,nres+k)
18290       zk=c(3,nres+k)
18291
18292       dxk=dc_norm(1,nres+k)
18293       dyk=dc_norm(2,nres+k)
18294       dzk=dc_norm(3,nres+k)
18295       dscj_inv=vbld_inv(k+nres)
18296       xij=xj-xi
18297       xik=xk-xi
18298       xjk=xk-xj
18299       yij=yj-yi
18300       yik=yk-yi
18301       yjk=yk-yj
18302       zij=zj-zi
18303       zik=zk-zi
18304       zjk=zk-zj
18305       rrij=(xij*xij+yij*yij+zij*zij)
18306       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18307       rrik=(xik*xik+yik*yik+zik*zik)
18308       rik=dsqrt(rrik)
18309       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18310       rjk=dsqrt(rrjk)
18311 !C there are three combination of distances for each trisulfide bonds
18312 !C The first case the ith atom is the center
18313 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18314 !C distance y is second distance the a,b,c,d are parameters derived for
18315 !C this problem d parameter was set as a penalty currenlty set to 1.
18316       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18317       eij1=0.0d0
18318       else
18319       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18320       endif
18321 !C second case jth atom is center
18322       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18323       eij2=0.0d0
18324       else
18325       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18326       endif
18327 !C the third case kth atom is the center
18328       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18329       eij3=0.0d0
18330       else
18331       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18332       endif
18333 !C      eij2=0.0
18334 !C      eij3=0.0
18335 !C      eij1=0.0
18336       eij=eij1+eij2+eij3
18337 !C      write(iout,*)i,j,k,eij
18338 !C The energy penalty calculated now time for the gradient part
18339 !C derivative over rij
18340       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18341       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18342             gg(1)=xij*fac/rij
18343             gg(2)=yij*fac/rij
18344             gg(3)=zij*fac/rij
18345       do m=1,3
18346         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18347         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18348       enddo
18349
18350       do l=1,3
18351         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18352         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18353       enddo
18354 !C now derivative over rik
18355       fac=-eij1**2/dtriss* &
18356       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18357       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18358             gg(1)=xik*fac/rik
18359             gg(2)=yik*fac/rik
18360             gg(3)=zik*fac/rik
18361       do m=1,3
18362         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18363         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18364       enddo
18365       do l=1,3
18366         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18367         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18368       enddo
18369 !C now derivative over rjk
18370       fac=-eij2**2/dtriss* &
18371       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18372       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18373             gg(1)=xjk*fac/rjk
18374             gg(2)=yjk*fac/rjk
18375             gg(3)=zjk*fac/rjk
18376       do m=1,3
18377         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18378         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18379       enddo
18380       do l=1,3
18381         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18382         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18383       enddo
18384       return
18385       end subroutine triple_ssbond_ene
18386
18387
18388
18389 !-----------------------------------------------------------------------------
18390       real(kind=8) function h_base(x,deriv)
18391 !     A smooth function going 0->1 in range [0,1]
18392 !     It should NOT be called outside range [0,1], it will not work there.
18393       implicit none
18394
18395 !     Input arguments
18396       real(kind=8) :: x
18397
18398 !     Output arguments
18399       real(kind=8) :: deriv
18400
18401 !     Local variables
18402       real(kind=8) :: xsq
18403
18404
18405 !     Two parabolas put together.  First derivative zero at extrema
18406 !$$$      if (x.lt.0.5D0) then
18407 !$$$        h_base=2.0D0*x*x
18408 !$$$        deriv=4.0D0*x
18409 !$$$      else
18410 !$$$        deriv=1.0D0-x
18411 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18412 !$$$        deriv=4.0D0*deriv
18413 !$$$      endif
18414
18415 !     Third degree polynomial.  First derivative zero at extrema
18416       h_base=x*x*(3.0d0-2.0d0*x)
18417       deriv=6.0d0*x*(1.0d0-x)
18418
18419 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18420 !$$$      xsq=x*x
18421 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18422 !$$$      deriv=x-1.0d0
18423 !$$$      deriv=deriv*deriv
18424 !$$$      deriv=30.0d0*xsq*deriv
18425
18426       return
18427       end function h_base
18428 !-----------------------------------------------------------------------------
18429       subroutine dyn_set_nss
18430 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18431 !      implicit none
18432       use MD_data, only: totT,t_bath
18433 !     Includes
18434 !      include 'DIMENSIONS'
18435 #ifdef MPI
18436       include "mpif.h"
18437 #endif
18438 !      include 'COMMON.SBRIDGE'
18439 !      include 'COMMON.CHAIN'
18440 !      include 'COMMON.IOUNITS'
18441 !      include 'COMMON.SETUP'
18442 !      include 'COMMON.MD'
18443 !     Local variables
18444       real(kind=8) :: emin
18445       integer :: i,j,imin,ierr
18446       integer :: diff,allnss,newnss
18447       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18448                 newihpb,newjhpb
18449       logical :: found
18450       integer,dimension(0:nfgtasks) :: i_newnss
18451       integer,dimension(0:nfgtasks) :: displ
18452       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18453       integer :: g_newnss
18454
18455       allnss=0
18456       do i=1,nres-1
18457         do j=i+1,nres
18458           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18459             allnss=allnss+1
18460             allflag(allnss)=0
18461             allihpb(allnss)=i
18462             alljhpb(allnss)=j
18463           endif
18464         enddo
18465       enddo
18466
18467 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18468
18469  1    emin=1.0d300
18470       do i=1,allnss
18471         if (allflag(i).eq.0 .and. &
18472              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18473           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18474           imin=i
18475         endif
18476       enddo
18477       if (emin.lt.1.0d300) then
18478         allflag(imin)=1
18479         do i=1,allnss
18480           if (allflag(i).eq.0 .and. &
18481                (allihpb(i).eq.allihpb(imin) .or. &
18482                alljhpb(i).eq.allihpb(imin) .or. &
18483                allihpb(i).eq.alljhpb(imin) .or. &
18484                alljhpb(i).eq.alljhpb(imin))) then
18485             allflag(i)=-1
18486           endif
18487         enddo
18488         goto 1
18489       endif
18490
18491 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18492
18493       newnss=0
18494       do i=1,allnss
18495         if (allflag(i).eq.1) then
18496           newnss=newnss+1
18497           newihpb(newnss)=allihpb(i)
18498           newjhpb(newnss)=alljhpb(i)
18499         endif
18500       enddo
18501
18502 #ifdef MPI
18503       if (nfgtasks.gt.1)then
18504
18505         call MPI_Reduce(newnss,g_newnss,1,&
18506           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18507         call MPI_Gather(newnss,1,MPI_INTEGER,&
18508                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18509         displ(0)=0
18510         do i=1,nfgtasks-1,1
18511           displ(i)=i_newnss(i-1)+displ(i-1)
18512         enddo
18513         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18514                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18515                          king,FG_COMM,IERR)
18516         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18517                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18518                          king,FG_COMM,IERR)
18519         if(fg_rank.eq.0) then
18520 !         print *,'g_newnss',g_newnss
18521 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18522 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18523          newnss=g_newnss
18524          do i=1,newnss
18525           newihpb(i)=g_newihpb(i)
18526           newjhpb(i)=g_newjhpb(i)
18527          enddo
18528         endif
18529       endif
18530 #endif
18531
18532       diff=newnss-nss
18533
18534 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18535 !       print *,newnss,nss,maxdim
18536       do i=1,nss
18537         found=.false.
18538 !        print *,newnss
18539         do j=1,newnss
18540 !!          print *,j
18541           if (idssb(i).eq.newihpb(j) .and. &
18542                jdssb(i).eq.newjhpb(j)) found=.true.
18543         enddo
18544 #ifndef CLUST
18545 #ifndef WHAM
18546 !        write(iout,*) "found",found,i,j
18547         if (.not.found.and.fg_rank.eq.0) &
18548             write(iout,'(a15,f12.2,f8.1,2i5)') &
18549              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18550 #endif
18551 #endif
18552       enddo
18553
18554       do i=1,newnss
18555         found=.false.
18556         do j=1,nss
18557 !          print *,i,j
18558           if (newihpb(i).eq.idssb(j) .and. &
18559                newjhpb(i).eq.jdssb(j)) found=.true.
18560         enddo
18561 #ifndef CLUST
18562 #ifndef WHAM
18563 !        write(iout,*) "found",found,i,j
18564         if (.not.found.and.fg_rank.eq.0) &
18565             write(iout,'(a15,f12.2,f8.1,2i5)') &
18566              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18567 #endif
18568 #endif
18569       enddo
18570
18571       nss=newnss
18572       do i=1,nss
18573         idssb(i)=newihpb(i)
18574         jdssb(i)=newjhpb(i)
18575       enddo
18576
18577       return
18578       end subroutine dyn_set_nss
18579 ! Lipid transfer energy function
18580       subroutine Eliptransfer(eliptran)
18581 !C this is done by Adasko
18582 !C      print *,"wchodze"
18583 !C structure of box:
18584 !C      water
18585 !C--bordliptop-- buffore starts
18586 !C--bufliptop--- here true lipid starts
18587 !C      lipid
18588 !C--buflipbot--- lipid ends buffore starts
18589 !C--bordlipbot--buffore ends
18590       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18591       integer :: i
18592       eliptran=0.0
18593 !      print *, "I am in eliptran"
18594       do i=ilip_start,ilip_end
18595 !C       do i=1,1
18596         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18597          cycle
18598
18599         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18600         if (positi.le.0.0) positi=positi+boxzsize
18601 !C        print *,i
18602 !C first for peptide groups
18603 !c for each residue check if it is in lipid or lipid water border area
18604        if ((positi.gt.bordlipbot)  &
18605       .and.(positi.lt.bordliptop)) then
18606 !C the energy transfer exist
18607         if (positi.lt.buflipbot) then
18608 !C what fraction I am in
18609          fracinbuf=1.0d0-      &
18610              ((positi-bordlipbot)/lipbufthick)
18611 !C lipbufthick is thickenes of lipid buffore
18612          sslip=sscalelip(fracinbuf)
18613          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18614          eliptran=eliptran+sslip*pepliptran
18615          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18616          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18617 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18618
18619 !C        print *,"doing sccale for lower part"
18620 !C         print *,i,sslip,fracinbuf,ssgradlip
18621         elseif (positi.gt.bufliptop) then
18622          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18623          sslip=sscalelip(fracinbuf)
18624          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18625          eliptran=eliptran+sslip*pepliptran
18626          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18627          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18628 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18629 !C          print *, "doing sscalefor top part"
18630 !C         print *,i,sslip,fracinbuf,ssgradlip
18631         else
18632          eliptran=eliptran+pepliptran
18633 !C         print *,"I am in true lipid"
18634         endif
18635 !C       else
18636 !C       eliptran=elpitran+0.0 ! I am in water
18637        endif
18638        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18639        enddo
18640 ! here starts the side chain transfer
18641        do i=ilip_start,ilip_end
18642         if (itype(i,1).eq.ntyp1) cycle
18643         positi=(mod(c(3,i+nres),boxzsize))
18644         if (positi.le.0) positi=positi+boxzsize
18645 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18646 !c for each residue check if it is in lipid or lipid water border area
18647 !C       respos=mod(c(3,i+nres),boxzsize)
18648 !C       print *,positi,bordlipbot,buflipbot
18649        if ((positi.gt.bordlipbot) &
18650        .and.(positi.lt.bordliptop)) then
18651 !C the energy transfer exist
18652         if (positi.lt.buflipbot) then
18653          fracinbuf=1.0d0-   &
18654            ((positi-bordlipbot)/lipbufthick)
18655 !C lipbufthick is thickenes of lipid buffore
18656          sslip=sscalelip(fracinbuf)
18657          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18658          eliptran=eliptran+sslip*liptranene(itype(i,1))
18659          gliptranx(3,i)=gliptranx(3,i) &
18660       +ssgradlip*liptranene(itype(i,1))
18661          gliptranc(3,i-1)= gliptranc(3,i-1) &
18662       +ssgradlip*liptranene(itype(i,1))
18663 !C         print *,"doing sccale for lower part"
18664         elseif (positi.gt.bufliptop) then
18665          fracinbuf=1.0d0-  &
18666       ((bordliptop-positi)/lipbufthick)
18667          sslip=sscalelip(fracinbuf)
18668          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18669          eliptran=eliptran+sslip*liptranene(itype(i,1))
18670          gliptranx(3,i)=gliptranx(3,i)  &
18671        +ssgradlip*liptranene(itype(i,1))
18672          gliptranc(3,i-1)= gliptranc(3,i-1) &
18673       +ssgradlip*liptranene(itype(i,1))
18674 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18675         else
18676          eliptran=eliptran+liptranene(itype(i,1))
18677 !C         print *,"I am in true lipid"
18678         endif
18679         endif ! if in lipid or buffor
18680 !C       else
18681 !C       eliptran=elpitran+0.0 ! I am in water
18682         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18683        enddo
18684        return
18685        end  subroutine Eliptransfer
18686 !----------------------------------NANO FUNCTIONS
18687 !C-----------------------------------------------------------------------
18688 !C-----------------------------------------------------------
18689 !C This subroutine is to mimic the histone like structure but as well can be
18690 !C utilizet to nanostructures (infinit) small modification has to be used to
18691 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18692 !C gradient has to be modified at the ends
18693 !C The energy function is Kihara potential
18694 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18695 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18696 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18697 !C simple Kihara potential
18698       subroutine calctube(Etube)
18699       real(kind=8),dimension(3) :: vectube
18700       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18701        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18702        sc_aa_tube,sc_bb_tube
18703       integer :: i,j,iti
18704       Etube=0.0d0
18705       do i=itube_start,itube_end
18706         enetube(i)=0.0d0
18707         enetube(i+nres)=0.0d0
18708       enddo
18709 !C first we calculate the distance from tube center
18710 !C for UNRES
18711        do i=itube_start,itube_end
18712 !C lets ommit dummy atoms for now
18713        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18714 !C now calculate distance from center of tube and direction vectors
18715       xmin=boxxsize
18716       ymin=boxysize
18717 ! Find minimum distance in periodic box
18718         do j=-1,1
18719          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18720          vectube(1)=vectube(1)+boxxsize*j
18721          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18722          vectube(2)=vectube(2)+boxysize*j
18723          xminact=abs(vectube(1)-tubecenter(1))
18724          yminact=abs(vectube(2)-tubecenter(2))
18725            if (xmin.gt.xminact) then
18726             xmin=xminact
18727             xtemp=vectube(1)
18728            endif
18729            if (ymin.gt.yminact) then
18730              ymin=yminact
18731              ytemp=vectube(2)
18732             endif
18733          enddo
18734       vectube(1)=xtemp
18735       vectube(2)=ytemp
18736       vectube(1)=vectube(1)-tubecenter(1)
18737       vectube(2)=vectube(2)-tubecenter(2)
18738
18739 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18740 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18741
18742 !C as the tube is infinity we do not calculate the Z-vector use of Z
18743 !C as chosen axis
18744       vectube(3)=0.0d0
18745 !C now calculte the distance
18746        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18747 !C now normalize vector
18748       vectube(1)=vectube(1)/tub_r
18749       vectube(2)=vectube(2)/tub_r
18750 !C calculte rdiffrence between r and r0
18751       rdiff=tub_r-tubeR0
18752 !C and its 6 power
18753       rdiff6=rdiff**6.0d0
18754 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18755        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18756 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18757 !C       print *,rdiff,rdiff6,pep_aa_tube
18758 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18759 !C now we calculate gradient
18760        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18761             6.0d0*pep_bb_tube)/rdiff6/rdiff
18762 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18763 !C     &rdiff,fac
18764 !C now direction of gg_tube vector
18765         do j=1,3
18766         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18767         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18768         enddo
18769         enddo
18770 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18771 !C        print *,gg_tube(1,0),"TU"
18772
18773
18774        do i=itube_start,itube_end
18775 !C Lets not jump over memory as we use many times iti
18776          iti=itype(i,1)
18777 !C lets ommit dummy atoms for now
18778          if ((iti.eq.ntyp1)  &
18779 !C in UNRES uncomment the line below as GLY has no side-chain...
18780 !C      .or.(iti.eq.10)
18781         ) cycle
18782       xmin=boxxsize
18783       ymin=boxysize
18784         do j=-1,1
18785          vectube(1)=mod((c(1,i+nres)),boxxsize)
18786          vectube(1)=vectube(1)+boxxsize*j
18787          vectube(2)=mod((c(2,i+nres)),boxysize)
18788          vectube(2)=vectube(2)+boxysize*j
18789
18790          xminact=abs(vectube(1)-tubecenter(1))
18791          yminact=abs(vectube(2)-tubecenter(2))
18792            if (xmin.gt.xminact) then
18793             xmin=xminact
18794             xtemp=vectube(1)
18795            endif
18796            if (ymin.gt.yminact) then
18797              ymin=yminact
18798              ytemp=vectube(2)
18799             endif
18800          enddo
18801       vectube(1)=xtemp
18802       vectube(2)=ytemp
18803 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18804 !C     &     tubecenter(2)
18805       vectube(1)=vectube(1)-tubecenter(1)
18806       vectube(2)=vectube(2)-tubecenter(2)
18807
18808 !C as the tube is infinity we do not calculate the Z-vector use of Z
18809 !C as chosen axis
18810       vectube(3)=0.0d0
18811 !C now calculte the distance
18812        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18813 !C now normalize vector
18814       vectube(1)=vectube(1)/tub_r
18815       vectube(2)=vectube(2)/tub_r
18816
18817 !C calculte rdiffrence between r and r0
18818       rdiff=tub_r-tubeR0
18819 !C and its 6 power
18820       rdiff6=rdiff**6.0d0
18821 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18822        sc_aa_tube=sc_aa_tube_par(iti)
18823        sc_bb_tube=sc_bb_tube_par(iti)
18824        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18825        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18826              6.0d0*sc_bb_tube/rdiff6/rdiff
18827 !C now direction of gg_tube vector
18828          do j=1,3
18829           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18830           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18831          enddo
18832         enddo
18833         do i=itube_start,itube_end
18834           Etube=Etube+enetube(i)+enetube(i+nres)
18835         enddo
18836 !C        print *,"ETUBE", etube
18837         return
18838         end subroutine calctube
18839 !C TO DO 1) add to total energy
18840 !C       2) add to gradient summation
18841 !C       3) add reading parameters (AND of course oppening of PARAM file)
18842 !C       4) add reading the center of tube
18843 !C       5) add COMMONs
18844 !C       6) add to zerograd
18845 !C       7) allocate matrices
18846
18847
18848 !C-----------------------------------------------------------------------
18849 !C-----------------------------------------------------------
18850 !C This subroutine is to mimic the histone like structure but as well can be
18851 !C utilizet to nanostructures (infinit) small modification has to be used to
18852 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18853 !C gradient has to be modified at the ends
18854 !C The energy function is Kihara potential
18855 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18856 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18857 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18858 !C simple Kihara potential
18859       subroutine calctube2(Etube)
18860             real(kind=8),dimension(3) :: vectube
18861       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18862        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18863        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18864       integer:: i,j,iti
18865       Etube=0.0d0
18866       do i=itube_start,itube_end
18867         enetube(i)=0.0d0
18868         enetube(i+nres)=0.0d0
18869       enddo
18870 !C first we calculate the distance from tube center
18871 !C first sugare-phosphate group for NARES this would be peptide group
18872 !C for UNRES
18873        do i=itube_start,itube_end
18874 !C lets ommit dummy atoms for now
18875
18876        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18877 !C now calculate distance from center of tube and direction vectors
18878 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18879 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18880 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18881 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18882       xmin=boxxsize
18883       ymin=boxysize
18884         do j=-1,1
18885          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18886          vectube(1)=vectube(1)+boxxsize*j
18887          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18888          vectube(2)=vectube(2)+boxysize*j
18889
18890          xminact=abs(vectube(1)-tubecenter(1))
18891          yminact=abs(vectube(2)-tubecenter(2))
18892            if (xmin.gt.xminact) then
18893             xmin=xminact
18894             xtemp=vectube(1)
18895            endif
18896            if (ymin.gt.yminact) then
18897              ymin=yminact
18898              ytemp=vectube(2)
18899             endif
18900          enddo
18901       vectube(1)=xtemp
18902       vectube(2)=ytemp
18903       vectube(1)=vectube(1)-tubecenter(1)
18904       vectube(2)=vectube(2)-tubecenter(2)
18905
18906 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18907 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18908
18909 !C as the tube is infinity we do not calculate the Z-vector use of Z
18910 !C as chosen axis
18911       vectube(3)=0.0d0
18912 !C now calculte the distance
18913        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18914 !C now normalize vector
18915       vectube(1)=vectube(1)/tub_r
18916       vectube(2)=vectube(2)/tub_r
18917 !C calculte rdiffrence between r and r0
18918       rdiff=tub_r-tubeR0
18919 !C and its 6 power
18920       rdiff6=rdiff**6.0d0
18921 !C THIS FRAGMENT MAKES TUBE FINITE
18922         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18923         if (positi.le.0) positi=positi+boxzsize
18924 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18925 !c for each residue check if it is in lipid or lipid water border area
18926 !C       respos=mod(c(3,i+nres),boxzsize)
18927 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18928        if ((positi.gt.bordtubebot)  &
18929         .and.(positi.lt.bordtubetop)) then
18930 !C the energy transfer exist
18931         if (positi.lt.buftubebot) then
18932          fracinbuf=1.0d0-  &
18933            ((positi-bordtubebot)/tubebufthick)
18934 !C lipbufthick is thickenes of lipid buffore
18935          sstube=sscalelip(fracinbuf)
18936          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18937 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18938          enetube(i)=enetube(i)+sstube*tubetranenepep
18939 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18940 !C     &+ssgradtube*tubetranene(itype(i,1))
18941 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18942 !C     &+ssgradtube*tubetranene(itype(i,1))
18943 !C         print *,"doing sccale for lower part"
18944         elseif (positi.gt.buftubetop) then
18945          fracinbuf=1.0d0-  &
18946         ((bordtubetop-positi)/tubebufthick)
18947          sstube=sscalelip(fracinbuf)
18948          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18949          enetube(i)=enetube(i)+sstube*tubetranenepep
18950 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18951 !C     &+ssgradtube*tubetranene(itype(i,1))
18952 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18953 !C     &+ssgradtube*tubetranene(itype(i,1))
18954 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18955         else
18956          sstube=1.0d0
18957          ssgradtube=0.0d0
18958          enetube(i)=enetube(i)+sstube*tubetranenepep
18959 !C         print *,"I am in true lipid"
18960         endif
18961         else
18962 !C          sstube=0.0d0
18963 !C          ssgradtube=0.0d0
18964         cycle
18965         endif ! if in lipid or buffor
18966
18967 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18968        enetube(i)=enetube(i)+sstube* &
18969         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18970 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18971 !C       print *,rdiff,rdiff6,pep_aa_tube
18972 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18973 !C now we calculate gradient
18974        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18975              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18976 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18977 !C     &rdiff,fac
18978
18979 !C now direction of gg_tube vector
18980        do j=1,3
18981         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18982         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18983         enddo
18984          gg_tube(3,i)=gg_tube(3,i)  &
18985        +ssgradtube*enetube(i)/sstube/2.0d0
18986          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18987        +ssgradtube*enetube(i)/sstube/2.0d0
18988
18989         enddo
18990 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18991 !C        print *,gg_tube(1,0),"TU"
18992         do i=itube_start,itube_end
18993 !C Lets not jump over memory as we use many times iti
18994          iti=itype(i,1)
18995 !C lets ommit dummy atoms for now
18996          if ((iti.eq.ntyp1) &
18997 !!C in UNRES uncomment the line below as GLY has no side-chain...
18998            .or.(iti.eq.10) &
18999           ) cycle
19000           vectube(1)=c(1,i+nres)
19001           vectube(1)=mod(vectube(1),boxxsize)
19002           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19003           vectube(2)=c(2,i+nres)
19004           vectube(2)=mod(vectube(2),boxysize)
19005           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19006
19007       vectube(1)=vectube(1)-tubecenter(1)
19008       vectube(2)=vectube(2)-tubecenter(2)
19009 !C THIS FRAGMENT MAKES TUBE FINITE
19010         positi=(mod(c(3,i+nres),boxzsize))
19011         if (positi.le.0) positi=positi+boxzsize
19012 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19013 !c for each residue check if it is in lipid or lipid water border area
19014 !C       respos=mod(c(3,i+nres),boxzsize)
19015 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19016
19017        if ((positi.gt.bordtubebot)  &
19018         .and.(positi.lt.bordtubetop)) then
19019 !C the energy transfer exist
19020         if (positi.lt.buftubebot) then
19021          fracinbuf=1.0d0- &
19022             ((positi-bordtubebot)/tubebufthick)
19023 !C lipbufthick is thickenes of lipid buffore
19024          sstube=sscalelip(fracinbuf)
19025          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19026 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19027          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19028 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19029 !C     &+ssgradtube*tubetranene(itype(i,1))
19030 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19031 !C     &+ssgradtube*tubetranene(itype(i,1))
19032 !C         print *,"doing sccale for lower part"
19033         elseif (positi.gt.buftubetop) then
19034          fracinbuf=1.0d0- &
19035         ((bordtubetop-positi)/tubebufthick)
19036
19037          sstube=sscalelip(fracinbuf)
19038          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19039          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19040 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19041 !C     &+ssgradtube*tubetranene(itype(i,1))
19042 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19043 !C     &+ssgradtube*tubetranene(itype(i,1))
19044 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19045         else
19046          sstube=1.0d0
19047          ssgradtube=0.0d0
19048          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19049 !C         print *,"I am in true lipid"
19050         endif
19051         else
19052 !C          sstube=0.0d0
19053 !C          ssgradtube=0.0d0
19054         cycle
19055         endif ! if in lipid or buffor
19056 !CEND OF FINITE FRAGMENT
19057 !C as the tube is infinity we do not calculate the Z-vector use of Z
19058 !C as chosen axis
19059       vectube(3)=0.0d0
19060 !C now calculte the distance
19061        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19062 !C now normalize vector
19063       vectube(1)=vectube(1)/tub_r
19064       vectube(2)=vectube(2)/tub_r
19065 !C calculte rdiffrence between r and r0
19066       rdiff=tub_r-tubeR0
19067 !C and its 6 power
19068       rdiff6=rdiff**6.0d0
19069 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19070        sc_aa_tube=sc_aa_tube_par(iti)
19071        sc_bb_tube=sc_bb_tube_par(iti)
19072        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19073                        *sstube+enetube(i+nres)
19074 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19075 !C now we calculate gradient
19076        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19077             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19078 !C now direction of gg_tube vector
19079          do j=1,3
19080           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19081           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19082          enddo
19083          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19084        +ssgradtube*enetube(i+nres)/sstube
19085          gg_tube(3,i-1)= gg_tube(3,i-1) &
19086        +ssgradtube*enetube(i+nres)/sstube
19087
19088         enddo
19089         do i=itube_start,itube_end
19090           Etube=Etube+enetube(i)+enetube(i+nres)
19091         enddo
19092 !C        print *,"ETUBE", etube
19093         return
19094         end subroutine calctube2
19095 !=====================================================================================================================================
19096       subroutine calcnano(Etube)
19097       real(kind=8),dimension(3) :: vectube
19098
19099       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19100        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19101        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19102        integer:: i,j,iti,r
19103
19104       Etube=0.0d0
19105 !      print *,itube_start,itube_end,"poczatek"
19106       do i=itube_start,itube_end
19107         enetube(i)=0.0d0
19108         enetube(i+nres)=0.0d0
19109       enddo
19110 !C first we calculate the distance from tube center
19111 !C first sugare-phosphate group for NARES this would be peptide group
19112 !C for UNRES
19113        do i=itube_start,itube_end
19114 !C lets ommit dummy atoms for now
19115        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19116 !C now calculate distance from center of tube and direction vectors
19117       xmin=boxxsize
19118       ymin=boxysize
19119       zmin=boxzsize
19120
19121         do j=-1,1
19122          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19123          vectube(1)=vectube(1)+boxxsize*j
19124          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19125          vectube(2)=vectube(2)+boxysize*j
19126          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19127          vectube(3)=vectube(3)+boxzsize*j
19128
19129
19130          xminact=dabs(vectube(1)-tubecenter(1))
19131          yminact=dabs(vectube(2)-tubecenter(2))
19132          zminact=dabs(vectube(3)-tubecenter(3))
19133
19134            if (xmin.gt.xminact) then
19135             xmin=xminact
19136             xtemp=vectube(1)
19137            endif
19138            if (ymin.gt.yminact) then
19139              ymin=yminact
19140              ytemp=vectube(2)
19141             endif
19142            if (zmin.gt.zminact) then
19143              zmin=zminact
19144              ztemp=vectube(3)
19145             endif
19146          enddo
19147       vectube(1)=xtemp
19148       vectube(2)=ytemp
19149       vectube(3)=ztemp
19150
19151       vectube(1)=vectube(1)-tubecenter(1)
19152       vectube(2)=vectube(2)-tubecenter(2)
19153       vectube(3)=vectube(3)-tubecenter(3)
19154
19155 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19156 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19157 !C as the tube is infinity we do not calculate the Z-vector use of Z
19158 !C as chosen axis
19159 !C      vectube(3)=0.0d0
19160 !C now calculte the distance
19161        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19162 !C now normalize vector
19163       vectube(1)=vectube(1)/tub_r
19164       vectube(2)=vectube(2)/tub_r
19165       vectube(3)=vectube(3)/tub_r
19166 !C calculte rdiffrence between r and r0
19167       rdiff=tub_r-tubeR0
19168 !C and its 6 power
19169       rdiff6=rdiff**6.0d0
19170 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19171        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19172 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19173 !C       print *,rdiff,rdiff6,pep_aa_tube
19174 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19175 !C now we calculate gradient
19176        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19177             6.0d0*pep_bb_tube)/rdiff6/rdiff
19178 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19179 !C     &rdiff,fac
19180          if (acavtubpep.eq.0.0d0) then
19181 !C go to 667
19182          enecavtube(i)=0.0
19183          faccav=0.0
19184          else
19185          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19186          enecavtube(i)=  &
19187         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19188         /denominator
19189          enecavtube(i)=0.0
19190          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19191         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19192         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19193         /denominator**2.0d0
19194 !C         faccav=0.0
19195 !C         fac=fac+faccav
19196 !C 667     continue
19197          endif
19198           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19199         do j=1,3
19200         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19201         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19202         enddo
19203         enddo
19204
19205        do i=itube_start,itube_end
19206         enecavtube(i)=0.0d0
19207 !C Lets not jump over memory as we use many times iti
19208          iti=itype(i,1)
19209 !C lets ommit dummy atoms for now
19210          if ((iti.eq.ntyp1) &
19211 !C in UNRES uncomment the line below as GLY has no side-chain...
19212 !C      .or.(iti.eq.10)
19213          ) cycle
19214       xmin=boxxsize
19215       ymin=boxysize
19216       zmin=boxzsize
19217         do j=-1,1
19218          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19219          vectube(1)=vectube(1)+boxxsize*j
19220          vectube(2)=dmod((c(2,i+nres)),boxysize)
19221          vectube(2)=vectube(2)+boxysize*j
19222          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19223          vectube(3)=vectube(3)+boxzsize*j
19224
19225
19226          xminact=dabs(vectube(1)-tubecenter(1))
19227          yminact=dabs(vectube(2)-tubecenter(2))
19228          zminact=dabs(vectube(3)-tubecenter(3))
19229
19230            if (xmin.gt.xminact) then
19231             xmin=xminact
19232             xtemp=vectube(1)
19233            endif
19234            if (ymin.gt.yminact) then
19235              ymin=yminact
19236              ytemp=vectube(2)
19237             endif
19238            if (zmin.gt.zminact) then
19239              zmin=zminact
19240              ztemp=vectube(3)
19241             endif
19242          enddo
19243       vectube(1)=xtemp
19244       vectube(2)=ytemp
19245       vectube(3)=ztemp
19246
19247 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19248 !C     &     tubecenter(2)
19249       vectube(1)=vectube(1)-tubecenter(1)
19250       vectube(2)=vectube(2)-tubecenter(2)
19251       vectube(3)=vectube(3)-tubecenter(3)
19252 !C now calculte the distance
19253        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19254 !C now normalize vector
19255       vectube(1)=vectube(1)/tub_r
19256       vectube(2)=vectube(2)/tub_r
19257       vectube(3)=vectube(3)/tub_r
19258
19259 !C calculte rdiffrence between r and r0
19260       rdiff=tub_r-tubeR0
19261 !C and its 6 power
19262       rdiff6=rdiff**6.0d0
19263        sc_aa_tube=sc_aa_tube_par(iti)
19264        sc_bb_tube=sc_bb_tube_par(iti)
19265        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19266 !C       enetube(i+nres)=0.0d0
19267 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19268 !C now we calculate gradient
19269        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19270             6.0d0*sc_bb_tube/rdiff6/rdiff
19271 !C       fac=0.0
19272 !C now direction of gg_tube vector
19273 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19274          if (acavtub(iti).eq.0.0d0) then
19275 !C go to 667
19276          enecavtube(i+nres)=0.0d0
19277          faccav=0.0d0
19278          else
19279          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19280          enecavtube(i+nres)=   &
19281         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19282         /denominator
19283 !C         enecavtube(i)=0.0
19284          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19285         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19286         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19287         /denominator**2.0d0
19288 !C         faccav=0.0
19289          fac=fac+faccav
19290 !C 667     continue
19291          endif
19292 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19293 !C     &   enecavtube(i),faccav
19294 !C         print *,"licz=",
19295 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19296 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19297          do j=1,3
19298           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19299           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19300          enddo
19301           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19302         enddo
19303
19304
19305
19306         do i=itube_start,itube_end
19307           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19308          +enecavtube(i+nres)
19309         enddo
19310 !        do i=1,20
19311 !         print *,"begin", i,"a"
19312 !         do r=1,10000
19313 !          rdiff=r/100.0d0
19314 !          rdiff6=rdiff**6.0d0
19315 !          sc_aa_tube=sc_aa_tube_par(i)
19316 !          sc_bb_tube=sc_bb_tube_par(i)
19317 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19318 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19319 !          enecavtube(i)=   &
19320 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19321 !         /denominator
19322
19323 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19324 !         enddo
19325 !         print *,"end",i,"a"
19326 !        enddo
19327 !C        print *,"ETUBE", etube
19328         return
19329         end subroutine calcnano
19330
19331 !===============================================
19332 !--------------------------------------------------------------------------------
19333 !C first for shielding is setting of function of side-chains
19334
19335        subroutine set_shield_fac2
19336        real(kind=8) :: div77_81=0.974996043d0, &
19337         div4_81=0.2222222222d0
19338        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19339          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19340          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19341          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19342 !C the vector between center of side_chain and peptide group
19343        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19344          pept_group,costhet_grad,cosphi_grad_long, &
19345          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19346          sh_frac_dist_grad,pep_side
19347         integer i,j,k
19348 !C      write(2,*) "ivec",ivec_start,ivec_end
19349       do i=1,nres
19350         fac_shield(i)=0.0d0
19351         do j=1,3
19352         grad_shield(j,i)=0.0d0
19353         enddo
19354       enddo
19355       do i=ivec_start,ivec_end
19356 !C      do i=1,nres-1
19357 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19358       ishield_list(i)=0
19359       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19360 !Cif there two consequtive dummy atoms there is no peptide group between them
19361 !C the line below has to be changed for FGPROC>1
19362       VolumeTotal=0.0
19363       do k=1,nres
19364        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19365        dist_pep_side=0.0
19366        dist_side_calf=0.0
19367        do j=1,3
19368 !C first lets set vector conecting the ithe side-chain with kth side-chain
19369       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19370 !C      pep_side(j)=2.0d0
19371 !C and vector conecting the side-chain with its proper calfa
19372       side_calf(j)=c(j,k+nres)-c(j,k)
19373 !C      side_calf(j)=2.0d0
19374       pept_group(j)=c(j,i)-c(j,i+1)
19375 !C lets have their lenght
19376       dist_pep_side=pep_side(j)**2+dist_pep_side
19377       dist_side_calf=dist_side_calf+side_calf(j)**2
19378       dist_pept_group=dist_pept_group+pept_group(j)**2
19379       enddo
19380        dist_pep_side=sqrt(dist_pep_side)
19381        dist_pept_group=sqrt(dist_pept_group)
19382        dist_side_calf=sqrt(dist_side_calf)
19383       do j=1,3
19384         pep_side_norm(j)=pep_side(j)/dist_pep_side
19385         side_calf_norm(j)=dist_side_calf
19386       enddo
19387 !C now sscale fraction
19388        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19389 !C       print *,buff_shield,"buff"
19390 !C now sscale
19391         if (sh_frac_dist.le.0.0) cycle
19392 !C        print *,ishield_list(i),i
19393 !C If we reach here it means that this side chain reaches the shielding sphere
19394 !C Lets add him to the list for gradient
19395         ishield_list(i)=ishield_list(i)+1
19396 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19397 !C this list is essential otherwise problem would be O3
19398         shield_list(ishield_list(i),i)=k
19399 !C Lets have the sscale value
19400         if (sh_frac_dist.gt.1.0) then
19401          scale_fac_dist=1.0d0
19402          do j=1,3
19403          sh_frac_dist_grad(j)=0.0d0
19404          enddo
19405         else
19406          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19407                         *(2.0d0*sh_frac_dist-3.0d0)
19408          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19409                        /dist_pep_side/buff_shield*0.5d0
19410          do j=1,3
19411          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19412 !C         sh_frac_dist_grad(j)=0.0d0
19413 !C         scale_fac_dist=1.0d0
19414 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19415 !C     &                    sh_frac_dist_grad(j)
19416          enddo
19417         endif
19418 !C this is what is now we have the distance scaling now volume...
19419       short=short_r_sidechain(itype(k,1))
19420       long=long_r_sidechain(itype(k,1))
19421       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19422       sinthet=short/dist_pep_side*costhet
19423 !C now costhet_grad
19424 !C       costhet=0.6d0
19425 !C       sinthet=0.8
19426        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19427 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19428 !C     &             -short/dist_pep_side**2/costhet)
19429 !C       costhet_fac=0.0d0
19430        do j=1,3
19431          costhet_grad(j)=costhet_fac*pep_side(j)
19432        enddo
19433 !C remember for the final gradient multiply costhet_grad(j)
19434 !C for side_chain by factor -2 !
19435 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19436 !C pep_side0pept_group is vector multiplication
19437       pep_side0pept_group=0.0d0
19438       do j=1,3
19439       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19440       enddo
19441       cosalfa=(pep_side0pept_group/ &
19442       (dist_pep_side*dist_side_calf))
19443       fac_alfa_sin=1.0d0-cosalfa**2
19444       fac_alfa_sin=dsqrt(fac_alfa_sin)
19445       rkprim=fac_alfa_sin*(long-short)+short
19446 !C      rkprim=short
19447
19448 !C now costhet_grad
19449        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19450 !C       cosphi=0.6
19451        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19452        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19453            dist_pep_side**2)
19454 !C       sinphi=0.8
19455        do j=1,3
19456          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19457       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19458       *(long-short)/fac_alfa_sin*cosalfa/ &
19459       ((dist_pep_side*dist_side_calf))* &
19460       ((side_calf(j))-cosalfa* &
19461       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19462 !C       cosphi_grad_long(j)=0.0d0
19463         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19464       *(long-short)/fac_alfa_sin*cosalfa &
19465       /((dist_pep_side*dist_side_calf))* &
19466       (pep_side(j)- &
19467       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19468 !C       cosphi_grad_loc(j)=0.0d0
19469        enddo
19470 !C      print *,sinphi,sinthet
19471       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19472      &                    /VSolvSphere_div
19473 !C     &                    *wshield
19474 !C now the gradient...
19475       do j=1,3
19476       grad_shield(j,i)=grad_shield(j,i) &
19477 !C gradient po skalowaniu
19478                      +(sh_frac_dist_grad(j)*VofOverlap &
19479 !C  gradient po costhet
19480             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19481         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19482             sinphi/sinthet*costhet*costhet_grad(j) &
19483            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19484         )*wshield
19485 !C grad_shield_side is Cbeta sidechain gradient
19486       grad_shield_side(j,ishield_list(i),i)=&
19487              (sh_frac_dist_grad(j)*-2.0d0&
19488              *VofOverlap&
19489             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19490        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19491             sinphi/sinthet*costhet*costhet_grad(j)&
19492            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19493             )*wshield
19494
19495        grad_shield_loc(j,ishield_list(i),i)=   &
19496             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19497       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19498             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19499              ))&
19500              *wshield
19501       enddo
19502       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19503       enddo
19504       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19505
19506 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19507       enddo
19508       return
19509       end subroutine set_shield_fac2
19510 !----------------------------------------------------------------------------
19511 ! SOUBROUTINE FOR AFM
19512        subroutine AFMvel(Eafmforce)
19513        use MD_data, only:totTafm
19514       real(kind=8),dimension(3) :: diffafm
19515       real(kind=8) :: afmdist,Eafmforce
19516        integer :: i
19517 !C Only for check grad COMMENT if not used for checkgrad
19518 !C      totT=3.0d0
19519 !C--------------------------------------------------------
19520 !C      print *,"wchodze"
19521       afmdist=0.0d0
19522       Eafmforce=0.0d0
19523       do i=1,3
19524       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19525       afmdist=afmdist+diffafm(i)**2
19526       enddo
19527       afmdist=dsqrt(afmdist)
19528 !      totTafm=3.0
19529       Eafmforce=0.5d0*forceAFMconst &
19530       *(distafminit+totTafm*velAFMconst-afmdist)**2
19531 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19532       do i=1,3
19533       gradafm(i,afmend-1)=-forceAFMconst* &
19534        (distafminit+totTafm*velAFMconst-afmdist) &
19535        *diffafm(i)/afmdist
19536       gradafm(i,afmbeg-1)=forceAFMconst* &
19537       (distafminit+totTafm*velAFMconst-afmdist) &
19538       *diffafm(i)/afmdist
19539       enddo
19540 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19541       return
19542       end subroutine AFMvel
19543 !---------------------------------------------------------
19544        subroutine AFMforce(Eafmforce)
19545
19546       real(kind=8),dimension(3) :: diffafm
19547 !      real(kind=8) ::afmdist
19548       real(kind=8) :: afmdist,Eafmforce
19549       integer :: i
19550       afmdist=0.0d0
19551       Eafmforce=0.0d0
19552       do i=1,3
19553       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19554       afmdist=afmdist+diffafm(i)**2
19555       enddo
19556       afmdist=dsqrt(afmdist)
19557 !      print *,afmdist,distafminit
19558       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19559       do i=1,3
19560       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19561       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19562       enddo
19563 !C      print *,'AFM',Eafmforce
19564       return
19565       end subroutine AFMforce
19566
19567 !-----------------------------------------------------------------------------
19568 #ifdef WHAM
19569       subroutine read_ssHist
19570 !      implicit none
19571 !      Includes
19572 !      include 'DIMENSIONS'
19573 !      include "DIMENSIONS.FREE"
19574 !      include 'COMMON.FREE'
19575 !     Local variables
19576       integer :: i,j
19577       character(len=80) :: controlcard
19578
19579       do i=1,dyn_nssHist
19580         call card_concat(controlcard,.true.)
19581         read(controlcard,*) &
19582              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19583       enddo
19584
19585       return
19586       end subroutine read_ssHist
19587 #endif
19588 !-----------------------------------------------------------------------------
19589       integer function indmat(i,j)
19590 !el
19591 ! get the position of the jth ijth fragment of the chain coordinate system
19592 ! in the fromto array.
19593         integer :: i,j
19594
19595         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19596       return
19597       end function indmat
19598 !-----------------------------------------------------------------------------
19599       real(kind=8) function sigm(x)
19600 !el
19601        real(kind=8) :: x
19602         sigm=0.25d0*x
19603       return
19604       end function sigm
19605 !-----------------------------------------------------------------------------
19606 !-----------------------------------------------------------------------------
19607       subroutine alloc_ener_arrays
19608 !EL Allocation of arrays used by module energy
19609       use MD_data, only: mset
19610 !el local variables
19611       integer :: i,j
19612
19613       if(nres.lt.100) then
19614         maxconts=nres
19615       elseif(nres.lt.200) then
19616         maxconts=0.8*nres      ! Max. number of contacts per residue
19617       else
19618         maxconts=0.6*nres ! (maxconts=maxres/4)
19619       endif
19620       maxcont=12*nres      ! Max. number of SC contacts
19621       maxvar=6*nres      ! Max. number of variables
19622 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19623       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19624 !----------------------
19625 ! arrays in subroutine init_int_table
19626 !el#ifdef MPI
19627 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19628 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19629 !el#endif
19630       allocate(nint_gr(nres))
19631       allocate(nscp_gr(nres))
19632       allocate(ielstart(nres))
19633       allocate(ielend(nres))
19634 !(maxres)
19635       allocate(istart(nres,maxint_gr))
19636       allocate(iend(nres,maxint_gr))
19637 !(maxres,maxint_gr)
19638       allocate(iscpstart(nres,maxint_gr))
19639       allocate(iscpend(nres,maxint_gr))
19640 !(maxres,maxint_gr)
19641       allocate(ielstart_vdw(nres))
19642       allocate(ielend_vdw(nres))
19643 !(maxres)
19644       allocate(nint_gr_nucl(nres))
19645       allocate(nscp_gr_nucl(nres))
19646       allocate(ielstart_nucl(nres))
19647       allocate(ielend_nucl(nres))
19648 !(maxres)
19649       allocate(istart_nucl(nres,maxint_gr))
19650       allocate(iend_nucl(nres,maxint_gr))
19651 !(maxres,maxint_gr)
19652       allocate(iscpstart_nucl(nres,maxint_gr))
19653       allocate(iscpend_nucl(nres,maxint_gr))
19654 !(maxres,maxint_gr)
19655       allocate(ielstart_vdw_nucl(nres))
19656       allocate(ielend_vdw_nucl(nres))
19657
19658       allocate(lentyp(0:nfgtasks-1))
19659 !(0:maxprocs-1)
19660 !----------------------
19661 ! commom.contacts
19662 !      common /contacts/
19663       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19664       allocate(icont(2,maxcont))
19665 !(2,maxcont)
19666 !      common /contacts1/
19667       allocate(num_cont(0:nres+4))
19668 !(maxres)
19669       allocate(jcont(maxconts,nres))
19670 !(maxconts,maxres)
19671       allocate(facont(maxconts,nres))
19672 !(maxconts,maxres)
19673       allocate(gacont(3,maxconts,nres))
19674 !(3,maxconts,maxres)
19675 !      common /contacts_hb/
19676       allocate(gacontp_hb1(3,maxconts,nres))
19677       allocate(gacontp_hb2(3,maxconts,nres))
19678       allocate(gacontp_hb3(3,maxconts,nres))
19679       allocate(gacontm_hb1(3,maxconts,nres))
19680       allocate(gacontm_hb2(3,maxconts,nres))
19681       allocate(gacontm_hb3(3,maxconts,nres))
19682       allocate(gacont_hbr(3,maxconts,nres))
19683       allocate(grij_hb_cont(3,maxconts,nres))
19684 !(3,maxconts,maxres)
19685       allocate(facont_hb(maxconts,nres))
19686
19687       allocate(ees0p(maxconts,nres))
19688       allocate(ees0m(maxconts,nres))
19689       allocate(d_cont(maxconts,nres))
19690       allocate(ees0plist(maxconts,nres))
19691
19692 !(maxconts,maxres)
19693       allocate(num_cont_hb(nres))
19694 !(maxres)
19695       allocate(jcont_hb(maxconts,nres))
19696 !(maxconts,maxres)
19697 !      common /rotat/
19698       allocate(Ug(2,2,nres))
19699       allocate(Ugder(2,2,nres))
19700       allocate(Ug2(2,2,nres))
19701       allocate(Ug2der(2,2,nres))
19702 !(2,2,maxres)
19703       allocate(obrot(2,nres))
19704       allocate(obrot2(2,nres))
19705       allocate(obrot_der(2,nres))
19706       allocate(obrot2_der(2,nres))
19707 !(2,maxres)
19708 !      common /precomp1/
19709       allocate(mu(2,nres))
19710       allocate(muder(2,nres))
19711       allocate(Ub2(2,nres))
19712       Ub2(1,:)=0.0d0
19713       Ub2(2,:)=0.0d0
19714       allocate(Ub2der(2,nres))
19715       allocate(Ctobr(2,nres))
19716       allocate(Ctobrder(2,nres))
19717       allocate(Dtobr2(2,nres))
19718       allocate(Dtobr2der(2,nres))
19719 !(2,maxres)
19720       allocate(EUg(2,2,nres))
19721       allocate(EUgder(2,2,nres))
19722       allocate(CUg(2,2,nres))
19723       allocate(CUgder(2,2,nres))
19724       allocate(DUg(2,2,nres))
19725       allocate(Dugder(2,2,nres))
19726       allocate(DtUg2(2,2,nres))
19727       allocate(DtUg2der(2,2,nres))
19728 !(2,2,maxres)
19729 !      common /precomp2/
19730       allocate(Ug2Db1t(2,nres))
19731       allocate(Ug2Db1tder(2,nres))
19732       allocate(CUgb2(2,nres))
19733       allocate(CUgb2der(2,nres))
19734 !(2,maxres)
19735       allocate(EUgC(2,2,nres))
19736       allocate(EUgCder(2,2,nres))
19737       allocate(EUgD(2,2,nres))
19738       allocate(EUgDder(2,2,nres))
19739       allocate(DtUg2EUg(2,2,nres))
19740       allocate(Ug2DtEUg(2,2,nres))
19741 !(2,2,maxres)
19742       allocate(Ug2DtEUgder(2,2,2,nres))
19743       allocate(DtUg2EUgder(2,2,2,nres))
19744 !(2,2,2,maxres)
19745 !      common /rotat_old/
19746       allocate(costab(nres))
19747       allocate(sintab(nres))
19748       allocate(costab2(nres))
19749       allocate(sintab2(nres))
19750 !(maxres)
19751 !      common /dipmat/
19752       allocate(a_chuj(2,2,maxconts,nres))
19753 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19754       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19755 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19756 !      common /contdistrib/
19757       allocate(ncont_sent(nres))
19758       allocate(ncont_recv(nres))
19759
19760       allocate(iat_sent(nres))
19761 !(maxres)
19762       allocate(iint_sent(4,nres,nres))
19763       allocate(iint_sent_local(4,nres,nres))
19764 !(4,maxres,maxres)
19765       allocate(iturn3_sent(4,0:nres+4))
19766       allocate(iturn4_sent(4,0:nres+4))
19767       allocate(iturn3_sent_local(4,nres))
19768       allocate(iturn4_sent_local(4,nres))
19769 !(4,maxres)
19770       allocate(itask_cont_from(0:nfgtasks-1))
19771       allocate(itask_cont_to(0:nfgtasks-1))
19772 !(0:max_fg_procs-1)
19773
19774
19775
19776 !----------------------
19777 ! commom.deriv;
19778 !      common /derivat/
19779       allocate(dcdv(6,maxdim))
19780       allocate(dxdv(6,maxdim))
19781 !(6,maxdim)
19782       allocate(dxds(6,nres))
19783 !(6,maxres)
19784       allocate(gradx(3,-1:nres,0:2))
19785       allocate(gradc(3,-1:nres,0:2))
19786 !(3,maxres,2)
19787       allocate(gvdwx(3,-1:nres))
19788       allocate(gvdwc(3,-1:nres))
19789       allocate(gelc(3,-1:nres))
19790       allocate(gelc_long(3,-1:nres))
19791       allocate(gvdwpp(3,-1:nres))
19792       allocate(gvdwc_scpp(3,-1:nres))
19793       allocate(gradx_scp(3,-1:nres))
19794       allocate(gvdwc_scp(3,-1:nres))
19795       allocate(ghpbx(3,-1:nres))
19796       allocate(ghpbc(3,-1:nres))
19797       allocate(gradcorr(3,-1:nres))
19798       allocate(gradcorr_long(3,-1:nres))
19799       allocate(gradcorr5_long(3,-1:nres))
19800       allocate(gradcorr6_long(3,-1:nres))
19801       allocate(gcorr6_turn_long(3,-1:nres))
19802       allocate(gradxorr(3,-1:nres))
19803       allocate(gradcorr5(3,-1:nres))
19804       allocate(gradcorr6(3,-1:nres))
19805       allocate(gliptran(3,-1:nres))
19806       allocate(gliptranc(3,-1:nres))
19807       allocate(gliptranx(3,-1:nres))
19808       allocate(gshieldx(3,-1:nres))
19809       allocate(gshieldc(3,-1:nres))
19810       allocate(gshieldc_loc(3,-1:nres))
19811       allocate(gshieldx_ec(3,-1:nres))
19812       allocate(gshieldc_ec(3,-1:nres))
19813       allocate(gshieldc_loc_ec(3,-1:nres))
19814       allocate(gshieldx_t3(3,-1:nres))
19815       allocate(gshieldc_t3(3,-1:nres))
19816       allocate(gshieldc_loc_t3(3,-1:nres))
19817       allocate(gshieldx_t4(3,-1:nres))
19818       allocate(gshieldc_t4(3,-1:nres))
19819       allocate(gshieldc_loc_t4(3,-1:nres))
19820       allocate(gshieldx_ll(3,-1:nres))
19821       allocate(gshieldc_ll(3,-1:nres))
19822       allocate(gshieldc_loc_ll(3,-1:nres))
19823       allocate(grad_shield(3,-1:nres))
19824       allocate(gg_tube_sc(3,-1:nres))
19825       allocate(gg_tube(3,-1:nres))
19826       allocate(gradafm(3,-1:nres))
19827       allocate(gradb_nucl(3,-1:nres))
19828       allocate(gradbx_nucl(3,-1:nres))
19829       allocate(gvdwpsb1(3,-1:nres))
19830       allocate(gelpp(3,-1:nres))
19831       allocate(gvdwpsb(3,-1:nres))
19832       allocate(gelsbc(3,-1:nres))
19833       allocate(gelsbx(3,-1:nres))
19834       allocate(gvdwsbx(3,-1:nres))
19835       allocate(gvdwsbc(3,-1:nres))
19836       allocate(gsbloc(3,-1:nres))
19837       allocate(gsblocx(3,-1:nres))
19838       allocate(gradcorr_nucl(3,-1:nres))
19839       allocate(gradxorr_nucl(3,-1:nres))
19840       allocate(gradcorr3_nucl(3,-1:nres))
19841       allocate(gradxorr3_nucl(3,-1:nres))
19842       allocate(gvdwpp_nucl(3,-1:nres))
19843       allocate(gradpepcat(3,-1:nres))
19844       allocate(gradpepcatx(3,-1:nres))
19845       allocate(gradcatcat(3,-1:nres))
19846 !(3,maxres)
19847       allocate(grad_shield_side(3,50,nres))
19848       allocate(grad_shield_loc(3,50,nres))
19849 ! grad for shielding surroing
19850       allocate(gloc(0:maxvar,0:2))
19851       allocate(gloc_x(0:maxvar,2))
19852 !(maxvar,2)
19853       allocate(gel_loc(3,-1:nres))
19854       allocate(gel_loc_long(3,-1:nres))
19855       allocate(gcorr3_turn(3,-1:nres))
19856       allocate(gcorr4_turn(3,-1:nres))
19857       allocate(gcorr6_turn(3,-1:nres))
19858       allocate(gradb(3,-1:nres))
19859       allocate(gradbx(3,-1:nres))
19860 !(3,maxres)
19861       allocate(gel_loc_loc(maxvar))
19862       allocate(gel_loc_turn3(maxvar))
19863       allocate(gel_loc_turn4(maxvar))
19864       allocate(gel_loc_turn6(maxvar))
19865       allocate(gcorr_loc(maxvar))
19866       allocate(g_corr5_loc(maxvar))
19867       allocate(g_corr6_loc(maxvar))
19868 !(maxvar)
19869       allocate(gsccorc(3,-1:nres))
19870       allocate(gsccorx(3,-1:nres))
19871 !(3,maxres)
19872       allocate(gsccor_loc(-1:nres))
19873 !(maxres)
19874       allocate(gvdwx_scbase(3,-1:nres))
19875       allocate(gvdwc_scbase(3,-1:nres))
19876       allocate(gvdwx_pepbase(3,-1:nres))
19877       allocate(gvdwc_pepbase(3,-1:nres))
19878       allocate(gvdwx_scpho(3,-1:nres))
19879       allocate(gvdwc_scpho(3,-1:nres))
19880       allocate(gvdwc_peppho(3,-1:nres))
19881
19882       allocate(dtheta(3,2,-1:nres))
19883 !(3,2,maxres)
19884       allocate(gscloc(3,-1:nres))
19885       allocate(gsclocx(3,-1:nres))
19886 !(3,maxres)
19887       allocate(dphi(3,3,-1:nres))
19888       allocate(dalpha(3,3,-1:nres))
19889       allocate(domega(3,3,-1:nres))
19890 !(3,3,maxres)
19891 !      common /deriv_scloc/
19892       allocate(dXX_C1tab(3,nres))
19893       allocate(dYY_C1tab(3,nres))
19894       allocate(dZZ_C1tab(3,nres))
19895       allocate(dXX_Ctab(3,nres))
19896       allocate(dYY_Ctab(3,nres))
19897       allocate(dZZ_Ctab(3,nres))
19898       allocate(dXX_XYZtab(3,nres))
19899       allocate(dYY_XYZtab(3,nres))
19900       allocate(dZZ_XYZtab(3,nres))
19901 !(3,maxres)
19902 !      common /mpgrad/
19903       allocate(jgrad_start(nres))
19904       allocate(jgrad_end(nres))
19905 !(maxres)
19906 !----------------------
19907
19908 !      common /indices/
19909       allocate(ibond_displ(0:nfgtasks-1))
19910       allocate(ibond_count(0:nfgtasks-1))
19911       allocate(ithet_displ(0:nfgtasks-1))
19912       allocate(ithet_count(0:nfgtasks-1))
19913       allocate(iphi_displ(0:nfgtasks-1))
19914       allocate(iphi_count(0:nfgtasks-1))
19915       allocate(iphi1_displ(0:nfgtasks-1))
19916       allocate(iphi1_count(0:nfgtasks-1))
19917       allocate(ivec_displ(0:nfgtasks-1))
19918       allocate(ivec_count(0:nfgtasks-1))
19919       allocate(iset_displ(0:nfgtasks-1))
19920       allocate(iset_count(0:nfgtasks-1))
19921       allocate(iint_count(0:nfgtasks-1))
19922       allocate(iint_displ(0:nfgtasks-1))
19923 !(0:max_fg_procs-1)
19924 !----------------------
19925 ! common.MD
19926 !      common /mdgrad/
19927       allocate(gcart(3,-1:nres))
19928       allocate(gxcart(3,-1:nres))
19929 !(3,0:MAXRES)
19930       allocate(gradcag(3,-1:nres))
19931       allocate(gradxag(3,-1:nres))
19932 !(3,MAXRES)
19933 !      common /back_constr/
19934 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19935       allocate(dutheta(nres))
19936       allocate(dugamma(nres))
19937 !(maxres)
19938       allocate(duscdiff(3,nres))
19939       allocate(duscdiffx(3,nres))
19940 !(3,maxres)
19941 !el i io:read_fragments
19942 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19943 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19944 !      common /qmeas/
19945 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19946 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19947       allocate(mset(0:nprocs))  !(maxprocs/20)
19948       mset(:)=0
19949 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19950 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19951       allocate(dUdconst(3,0:nres))
19952       allocate(dUdxconst(3,0:nres))
19953       allocate(dqwol(3,0:nres))
19954       allocate(dxqwol(3,0:nres))
19955 !(3,0:MAXRES)
19956 !----------------------
19957 ! common.sbridge
19958 !      common /sbridge/ in io_common: read_bridge
19959 !el    allocate((:),allocatable :: iss      !(maxss)
19960 !      common /links/  in io_common: read_bridge
19961 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19962 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19963 !      common /dyn_ssbond/
19964 ! and side-chain vectors in theta or phi.
19965       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19966 !(maxres,maxres)
19967 !      do i=1,nres
19968 !        do j=i+1,nres
19969       dyn_ssbond_ij(:,:)=1.0d300
19970 !        enddo
19971 !      enddo
19972
19973 !      if (nss.gt.0) then
19974         allocate(idssb(maxdim),jdssb(maxdim))
19975 !        allocate(newihpb(nss),newjhpb(nss))
19976 !(maxdim)
19977 !      endif
19978       allocate(ishield_list(nres))
19979       allocate(shield_list(50,nres))
19980       allocate(dyn_ss_mask(nres))
19981       allocate(fac_shield(nres))
19982       allocate(enetube(nres*2))
19983       allocate(enecavtube(nres*2))
19984
19985 !(maxres)
19986       dyn_ss_mask(:)=.false.
19987 !----------------------
19988 ! common.sccor
19989 ! Parameters of the SCCOR term
19990 !      common/sccor/
19991 !el in io_conf: parmread
19992 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19993 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19994 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19995 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19996 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19997 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19998 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19999 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20000 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20001 !----------------
20002       allocate(gloc_sc(3,0:2*nres,0:10))
20003 !(3,0:maxres2,10)maxres2=2*maxres
20004       allocate(dcostau(3,3,3,2*nres))
20005       allocate(dsintau(3,3,3,2*nres))
20006       allocate(dtauangle(3,3,3,2*nres))
20007       allocate(dcosomicron(3,3,3,2*nres))
20008       allocate(domicron(3,3,3,2*nres))
20009 !(3,3,3,maxres2)maxres2=2*maxres
20010 !----------------------
20011 ! common.var
20012 !      common /restr/
20013       allocate(varall(maxvar))
20014 !(maxvar)(maxvar=6*maxres)
20015       allocate(mask_theta(nres))
20016       allocate(mask_phi(nres))
20017       allocate(mask_side(nres))
20018 !(maxres)
20019 !----------------------
20020 ! common.vectors
20021 !      common /vectors/
20022       allocate(uy(3,nres))
20023       allocate(uz(3,nres))
20024 !(3,maxres)
20025       allocate(uygrad(3,3,2,nres))
20026       allocate(uzgrad(3,3,2,nres))
20027 !(3,3,2,maxres)
20028
20029       return
20030       end subroutine alloc_ener_arrays
20031 !-----------------------------------------------------------------
20032       subroutine ebond_nucl(estr_nucl)
20033 !c
20034 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20035 !c
20036
20037       real(kind=8),dimension(3) :: u,ud
20038       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20039       real(kind=8) :: estr_nucl,diff
20040       integer :: iti,i,j,k,nbi
20041       estr_nucl=0.0d0
20042 !C      print *,"I enter ebond"
20043       if (energy_dec) &
20044       write (iout,*) "ibondp_start,ibondp_end",&
20045        ibondp_nucl_start,ibondp_nucl_end
20046       do i=ibondp_nucl_start,ibondp_nucl_end
20047         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20048          itype(i,2).eq.ntyp1_molec(2)) cycle
20049 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20050 !          do j=1,3
20051 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20052 !     &      *dc(j,i-1)/vbld(i)
20053 !          enddo
20054 !          if (energy_dec) write(iout,*)
20055 !     &       "estr1",i,vbld(i),distchainmax,
20056 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20057
20058           diff = vbld(i)-vbldp0_nucl
20059           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20060           vbldp0_nucl,diff,AKP_nucl*diff*diff
20061           estr_nucl=estr_nucl+diff*diff
20062 !          print *,estr_nucl
20063           do j=1,3
20064             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20065           enddo
20066 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20067       enddo
20068       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20069 !      print *,"partial sum", estr_nucl,AKP_nucl
20070
20071       if (energy_dec) &
20072       write (iout,*) "ibondp_start,ibondp_end",&
20073        ibond_nucl_start,ibond_nucl_end
20074
20075       do i=ibond_nucl_start,ibond_nucl_end
20076 !C        print *, "I am stuck",i
20077         iti=itype(i,2)
20078         if (iti.eq.ntyp1_molec(2)) cycle
20079           nbi=nbondterm_nucl(iti)
20080 !C        print *,iti,nbi
20081           if (nbi.eq.1) then
20082             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20083
20084             if (energy_dec) &
20085            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20086            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20087             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20088 !            print *,estr_nucl
20089             do j=1,3
20090               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20091             enddo
20092           else
20093             do j=1,nbi
20094               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20095               ud(j)=aksc_nucl(j,iti)*diff
20096               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20097             enddo
20098             uprod=u(1)
20099             do j=2,nbi
20100               uprod=uprod*u(j)
20101             enddo
20102             usum=0.0d0
20103             usumsqder=0.0d0
20104             do j=1,nbi
20105               uprod1=1.0d0
20106               uprod2=1.0d0
20107               do k=1,nbi
20108                 if (k.ne.j) then
20109                   uprod1=uprod1*u(k)
20110                   uprod2=uprod2*u(k)*u(k)
20111                 endif
20112               enddo
20113               usum=usum+uprod1
20114               usumsqder=usumsqder+ud(j)*uprod2
20115             enddo
20116             estr_nucl=estr_nucl+uprod/usum
20117             do j=1,3
20118              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20119             enddo
20120         endif
20121       enddo
20122 !C      print *,"I am about to leave ebond"
20123       return
20124       end subroutine ebond_nucl
20125
20126 !-----------------------------------------------------------------------------
20127       subroutine ebend_nucl(etheta_nucl)
20128       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20129       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20130       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20131       logical :: lprn=.false., lprn1=.false.
20132 !el local variables
20133       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20134       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20135       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20136 ! local variables for constrains
20137       real(kind=8) :: difi,thetiii
20138        integer itheta
20139       etheta_nucl=0.0D0
20140 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20141       do i=ithet_nucl_start,ithet_nucl_end
20142         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20143         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20144         (itype(i,2).eq.ntyp1_molec(2))) cycle
20145         dethetai=0.0d0
20146         dephii=0.0d0
20147         dephii1=0.0d0
20148         theti2=0.5d0*theta(i)
20149         ityp2=ithetyp_nucl(itype(i-1,2))
20150         do k=1,nntheterm_nucl
20151           coskt(k)=dcos(k*theti2)
20152           sinkt(k)=dsin(k*theti2)
20153         enddo
20154         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20155 #ifdef OSF
20156           phii=phi(i)
20157           if (phii.ne.phii) phii=150.0
20158 #else
20159           phii=phi(i)
20160 #endif
20161           ityp1=ithetyp_nucl(itype(i-2,2))
20162           do k=1,nsingle_nucl
20163             cosph1(k)=dcos(k*phii)
20164             sinph1(k)=dsin(k*phii)
20165           enddo
20166         else
20167           phii=0.0d0
20168           ityp1=nthetyp_nucl+1
20169           do k=1,nsingle_nucl
20170             cosph1(k)=0.0d0
20171             sinph1(k)=0.0d0
20172           enddo
20173         endif
20174
20175         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20176 #ifdef OSF
20177           phii1=phi(i+1)
20178           if (phii1.ne.phii1) phii1=150.0
20179           phii1=pinorm(phii1)
20180 #else
20181           phii1=phi(i+1)
20182 #endif
20183           ityp3=ithetyp_nucl(itype(i,2))
20184           do k=1,nsingle_nucl
20185             cosph2(k)=dcos(k*phii1)
20186             sinph2(k)=dsin(k*phii1)
20187           enddo
20188         else
20189           phii1=0.0d0
20190           ityp3=nthetyp_nucl+1
20191           do k=1,nsingle_nucl
20192             cosph2(k)=0.0d0
20193             sinph2(k)=0.0d0
20194           enddo
20195         endif
20196         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20197         do k=1,ndouble_nucl
20198           do l=1,k-1
20199             ccl=cosph1(l)*cosph2(k-l)
20200             ssl=sinph1(l)*sinph2(k-l)
20201             scl=sinph1(l)*cosph2(k-l)
20202             csl=cosph1(l)*sinph2(k-l)
20203             cosph1ph2(l,k)=ccl-ssl
20204             cosph1ph2(k,l)=ccl+ssl
20205             sinph1ph2(l,k)=scl+csl
20206             sinph1ph2(k,l)=scl-csl
20207           enddo
20208         enddo
20209         if (lprn) then
20210         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20211          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20212         write (iout,*) "coskt and sinkt",nntheterm_nucl
20213         do k=1,nntheterm_nucl
20214           write (iout,*) k,coskt(k),sinkt(k)
20215         enddo
20216         endif
20217         do k=1,ntheterm_nucl
20218           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20219           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20220            *coskt(k)
20221           if (lprn)&
20222          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20223           " ethetai",ethetai
20224         enddo
20225         if (lprn) then
20226         write (iout,*) "cosph and sinph"
20227         do k=1,nsingle_nucl
20228           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20229         enddo
20230         write (iout,*) "cosph1ph2 and sinph2ph2"
20231         do k=2,ndouble_nucl
20232           do l=1,k-1
20233             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20234               sinph1ph2(l,k),sinph1ph2(k,l)
20235           enddo
20236         enddo
20237         write(iout,*) "ethetai",ethetai
20238         endif
20239         do m=1,ntheterm2_nucl
20240           do k=1,nsingle_nucl
20241             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20242               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20243               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20244               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20245             ethetai=ethetai+sinkt(m)*aux
20246             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20247             dephii=dephii+k*sinkt(m)*(&
20248                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20249                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20250             dephii1=dephii1+k*sinkt(m)*(&
20251                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20252                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20253             if (lprn) &
20254            write (iout,*) "m",m," k",k," bbthet",&
20255               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20256               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20257               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20258               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20259           enddo
20260         enddo
20261         if (lprn) &
20262         write(iout,*) "ethetai",ethetai
20263         do m=1,ntheterm3_nucl
20264           do k=2,ndouble_nucl
20265             do l=1,k-1
20266               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20267                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20268                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20269                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20270               ethetai=ethetai+sinkt(m)*aux
20271               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20272               dephii=dephii+l*sinkt(m)*(&
20273                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20274                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20275                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20276                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20277               dephii1=dephii1+(k-l)*sinkt(m)*( &
20278                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20279                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20280                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20281                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20282               if (lprn) then
20283               write (iout,*) "m",m," k",k," l",l," ffthet", &
20284                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20285                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20286                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20287                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20288               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20289                  cosph1ph2(k,l)*sinkt(m),&
20290                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20291               endif
20292             enddo
20293           enddo
20294         enddo
20295 10      continue
20296         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20297         i,theta(i)*rad2deg,phii*rad2deg, &
20298         phii1*rad2deg,ethetai
20299         etheta_nucl=etheta_nucl+ethetai
20300 !        print *,i,"partial sum",etheta_nucl
20301         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20302         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20303         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20304       enddo
20305       return
20306       end subroutine ebend_nucl
20307 !----------------------------------------------------
20308       subroutine etor_nucl(etors_nucl)
20309 !      implicit real*8 (a-h,o-z)
20310 !      include 'DIMENSIONS'
20311 !      include 'COMMON.VAR'
20312 !      include 'COMMON.GEO'
20313 !      include 'COMMON.LOCAL'
20314 !      include 'COMMON.TORSION'
20315 !      include 'COMMON.INTERACT'
20316 !      include 'COMMON.DERIV'
20317 !      include 'COMMON.CHAIN'
20318 !      include 'COMMON.NAMES'
20319 !      include 'COMMON.IOUNITS'
20320 !      include 'COMMON.FFIELD'
20321 !      include 'COMMON.TORCNSTR'
20322 !      include 'COMMON.CONTROL'
20323       real(kind=8) :: etors_nucl,edihcnstr
20324       logical :: lprn
20325 !el local variables
20326       integer :: i,j,iblock,itori,itori1
20327       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20328                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20329 ! Set lprn=.true. for debugging
20330       lprn=.false.
20331 !     lprn=.true.
20332       etors_nucl=0.0D0
20333 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20334       do i=iphi_nucl_start,iphi_nucl_end
20335         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20336              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20337              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20338         etors_ii=0.0D0
20339         itori=itortyp_nucl(itype(i-2,2))
20340         itori1=itortyp_nucl(itype(i-1,2))
20341         phii=phi(i)
20342 !         print *,i,itori,itori1
20343         gloci=0.0D0
20344 !C Regular cosine and sine terms
20345         do j=1,nterm_nucl(itori,itori1)
20346           v1ij=v1_nucl(j,itori,itori1)
20347           v2ij=v2_nucl(j,itori,itori1)
20348           cosphi=dcos(j*phii)
20349           sinphi=dsin(j*phii)
20350           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20351           if (energy_dec) etors_ii=etors_ii+&
20352                      v1ij*cosphi+v2ij*sinphi
20353           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20354         enddo
20355 !C Lorentz terms
20356 !C                         v1
20357 !C  E = SUM ----------------------------------- - v1
20358 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20359 !C
20360         cosphi=dcos(0.5d0*phii)
20361         sinphi=dsin(0.5d0*phii)
20362         do j=1,nlor_nucl(itori,itori1)
20363           vl1ij=vlor1_nucl(j,itori,itori1)
20364           vl2ij=vlor2_nucl(j,itori,itori1)
20365           vl3ij=vlor3_nucl(j,itori,itori1)
20366           pom=vl2ij*cosphi+vl3ij*sinphi
20367           pom1=1.0d0/(pom*pom+1.0d0)
20368           etors_nucl=etors_nucl+vl1ij*pom1
20369           if (energy_dec) etors_ii=etors_ii+ &
20370                      vl1ij*pom1
20371           pom=-pom*pom1*pom1
20372           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20373         enddo
20374 !C Subtract the constant term
20375         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20376           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20377               'etor',i,etors_ii-v0_nucl(itori,itori1)
20378         if (lprn) &
20379        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20380        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20381        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20382         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20383 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20384       enddo
20385       return
20386       end subroutine etor_nucl
20387 !------------------------------------------------------------
20388       subroutine epp_nucl_sub(evdw1,ees)
20389 !C
20390 !C This subroutine calculates the average interaction energy and its gradient
20391 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20392 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20393 !C The potential depends both on the distance of peptide-group centers and on
20394 !C the orientation of the CA-CA virtual bonds.
20395 !C
20396       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20397       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20398       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20399                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20400                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20401       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20402                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20403       integer xshift,yshift,zshift
20404       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20405       real(kind=8) :: ees,eesij
20406 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20407       real(kind=8) scal_el /0.5d0/
20408       t_eelecij=0.0d0
20409       ees=0.0D0
20410       evdw1=0.0D0
20411       ind=0
20412 !c
20413 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20414 !c
20415 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20416       do i=iatel_s_nucl,iatel_e_nucl
20417         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20418         dxi=dc(1,i)
20419         dyi=dc(2,i)
20420         dzi=dc(3,i)
20421         dx_normi=dc_norm(1,i)
20422         dy_normi=dc_norm(2,i)
20423         dz_normi=dc_norm(3,i)
20424         xmedi=c(1,i)+0.5d0*dxi
20425         ymedi=c(2,i)+0.5d0*dyi
20426         zmedi=c(3,i)+0.5d0*dzi
20427           xmedi=dmod(xmedi,boxxsize)
20428           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20429           ymedi=dmod(ymedi,boxysize)
20430           if (ymedi.lt.0) ymedi=ymedi+boxysize
20431           zmedi=dmod(zmedi,boxzsize)
20432           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20433
20434         do j=ielstart_nucl(i),ielend_nucl(i)
20435           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20436           ind=ind+1
20437           dxj=dc(1,j)
20438           dyj=dc(2,j)
20439           dzj=dc(3,j)
20440 !          xj=c(1,j)+0.5D0*dxj-xmedi
20441 !          yj=c(2,j)+0.5D0*dyj-ymedi
20442 !          zj=c(3,j)+0.5D0*dzj-zmedi
20443           xj=c(1,j)+0.5D0*dxj
20444           yj=c(2,j)+0.5D0*dyj
20445           zj=c(3,j)+0.5D0*dzj
20446           xj=mod(xj,boxxsize)
20447           if (xj.lt.0) xj=xj+boxxsize
20448           yj=mod(yj,boxysize)
20449           if (yj.lt.0) yj=yj+boxysize
20450           zj=mod(zj,boxzsize)
20451           if (zj.lt.0) zj=zj+boxzsize
20452       isubchap=0
20453       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20454       xj_safe=xj
20455       yj_safe=yj
20456       zj_safe=zj
20457       do xshift=-1,1
20458       do yshift=-1,1
20459       do zshift=-1,1
20460           xj=xj_safe+xshift*boxxsize
20461           yj=yj_safe+yshift*boxysize
20462           zj=zj_safe+zshift*boxzsize
20463           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20464           if(dist_temp.lt.dist_init) then
20465             dist_init=dist_temp
20466             xj_temp=xj
20467             yj_temp=yj
20468             zj_temp=zj
20469             isubchap=1
20470           endif
20471        enddo
20472        enddo
20473        enddo
20474        if (isubchap.eq.1) then
20475 !C          print *,i,j
20476           xj=xj_temp-xmedi
20477           yj=yj_temp-ymedi
20478           zj=zj_temp-zmedi
20479        else
20480           xj=xj_safe-xmedi
20481           yj=yj_safe-ymedi
20482           zj=zj_safe-zmedi
20483        endif
20484
20485           rij=xj*xj+yj*yj+zj*zj
20486 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20487           fac=(r0pp**2/rij)**3
20488           ev1=epspp*fac*fac
20489           ev2=epspp*fac
20490           evdw1ij=ev1-2*ev2
20491           fac=(-ev1-evdw1ij)/rij
20492 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20493           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20494           evdw1=evdw1+evdw1ij
20495 !C
20496 !C Calculate contributions to the Cartesian gradient.
20497 !C
20498           ggg(1)=fac*xj
20499           ggg(2)=fac*yj
20500           ggg(3)=fac*zj
20501           do k=1,3
20502             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20503             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20504           enddo
20505 !c phoshate-phosphate electrostatic interactions
20506           rij=dsqrt(rij)
20507           fac=1.0d0/rij
20508           eesij=dexp(-BEES*rij)*fac
20509 !          write (2,*)"fac",fac," eesijpp",eesij
20510           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20511           ees=ees+eesij
20512 !c          fac=-eesij*fac
20513           fac=-(fac+BEES)*eesij*fac
20514           ggg(1)=fac*xj
20515           ggg(2)=fac*yj
20516           ggg(3)=fac*zj
20517 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20518 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20519 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20520           do k=1,3
20521             gelpp(k,i)=gelpp(k,i)-ggg(k)
20522             gelpp(k,j)=gelpp(k,j)+ggg(k)
20523           enddo
20524         enddo ! j
20525       enddo   ! i
20526 !c      ees=332.0d0*ees
20527       ees=AEES*ees
20528       do i=nnt,nct
20529 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20530         do k=1,3
20531           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20532 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20533           gelpp(k,i)=AEES*gelpp(k,i)
20534         enddo
20535 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20536       enddo
20537 !c      write (2,*) "total EES",ees
20538       return
20539       end subroutine epp_nucl_sub
20540 !---------------------------------------------------------------------
20541       subroutine epsb(evdwpsb,eelpsb)
20542 !      use comm_locel
20543 !C
20544 !C This subroutine calculates the excluded-volume interaction energy between
20545 !C peptide-group centers and side chains and its gradient in virtual-bond and
20546 !C side-chain vectors.
20547 !C
20548       real(kind=8),dimension(3):: ggg
20549       integer :: i,iint,j,k,iteli,itypj,subchap
20550       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20551                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20552       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20553                     dist_temp, dist_init
20554       integer xshift,yshift,zshift
20555
20556 !cd    print '(a)','Enter ESCP'
20557 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20558       eelpsb=0.0d0
20559       evdwpsb=0.0d0
20560 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20561       do i=iatscp_s_nucl,iatscp_e_nucl
20562         if (itype(i,2).eq.ntyp1_molec(2) &
20563          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20564         xi=0.5D0*(c(1,i)+c(1,i+1))
20565         yi=0.5D0*(c(2,i)+c(2,i+1))
20566         zi=0.5D0*(c(3,i)+c(3,i+1))
20567           xi=mod(xi,boxxsize)
20568           if (xi.lt.0) xi=xi+boxxsize
20569           yi=mod(yi,boxysize)
20570           if (yi.lt.0) yi=yi+boxysize
20571           zi=mod(zi,boxzsize)
20572           if (zi.lt.0) zi=zi+boxzsize
20573
20574         do iint=1,nscp_gr_nucl(i)
20575
20576         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20577           itypj=itype(j,2)
20578           if (itypj.eq.ntyp1_molec(2)) cycle
20579 !C Uncomment following three lines for SC-p interactions
20580 !c         xj=c(1,nres+j)-xi
20581 !c         yj=c(2,nres+j)-yi
20582 !c         zj=c(3,nres+j)-zi
20583 !C Uncomment following three lines for Ca-p interactions
20584 !          xj=c(1,j)-xi
20585 !          yj=c(2,j)-yi
20586 !          zj=c(3,j)-zi
20587           xj=c(1,j)
20588           yj=c(2,j)
20589           zj=c(3,j)
20590           xj=mod(xj,boxxsize)
20591           if (xj.lt.0) xj=xj+boxxsize
20592           yj=mod(yj,boxysize)
20593           if (yj.lt.0) yj=yj+boxysize
20594           zj=mod(zj,boxzsize)
20595           if (zj.lt.0) zj=zj+boxzsize
20596       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20597       xj_safe=xj
20598       yj_safe=yj
20599       zj_safe=zj
20600       subchap=0
20601       do xshift=-1,1
20602       do yshift=-1,1
20603       do zshift=-1,1
20604           xj=xj_safe+xshift*boxxsize
20605           yj=yj_safe+yshift*boxysize
20606           zj=zj_safe+zshift*boxzsize
20607           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20608           if(dist_temp.lt.dist_init) then
20609             dist_init=dist_temp
20610             xj_temp=xj
20611             yj_temp=yj
20612             zj_temp=zj
20613             subchap=1
20614           endif
20615        enddo
20616        enddo
20617        enddo
20618        if (subchap.eq.1) then
20619           xj=xj_temp-xi
20620           yj=yj_temp-yi
20621           zj=zj_temp-zi
20622        else
20623           xj=xj_safe-xi
20624           yj=yj_safe-yi
20625           zj=zj_safe-zi
20626        endif
20627
20628           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20629           fac=rrij**expon2
20630           e1=fac*fac*aad_nucl(itypj)
20631           e2=fac*bad_nucl(itypj)
20632           if (iabs(j-i) .le. 2) then
20633             e1=scal14*e1
20634             e2=scal14*e2
20635           endif
20636           evdwij=e1+e2
20637           evdwpsb=evdwpsb+evdwij
20638           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20639              'evdw2',i,j,evdwij,"tu4"
20640 !C
20641 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20642 !C
20643           fac=-(evdwij+e1)*rrij
20644           ggg(1)=xj*fac
20645           ggg(2)=yj*fac
20646           ggg(3)=zj*fac
20647           do k=1,3
20648             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20649             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20650           enddo
20651         enddo
20652
20653         enddo ! iint
20654       enddo ! i
20655       do i=1,nct
20656         do j=1,3
20657           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20658           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20659         enddo
20660       enddo
20661       return
20662       end subroutine epsb
20663
20664 !------------------------------------------------------
20665       subroutine esb_gb(evdwsb,eelsb)
20666       use comm_locel
20667       use calc_data_nucl
20668       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20669       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20670       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20671       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20672                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20673       integer :: ii
20674       logical lprn
20675       evdw=0.0D0
20676       eelsb=0.0d0
20677       ecorr=0.0d0
20678       evdwsb=0.0D0
20679       lprn=.false.
20680       ind=0
20681 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20682       do i=iatsc_s_nucl,iatsc_e_nucl
20683         num_conti=0
20684         num_conti2=0
20685         itypi=itype(i,2)
20686 !        PRINT *,"I=",i,itypi
20687         if (itypi.eq.ntyp1_molec(2)) cycle
20688         itypi1=itype(i+1,2)
20689         xi=c(1,nres+i)
20690         yi=c(2,nres+i)
20691         zi=c(3,nres+i)
20692           xi=dmod(xi,boxxsize)
20693           if (xi.lt.0) xi=xi+boxxsize
20694           yi=dmod(yi,boxysize)
20695           if (yi.lt.0) yi=yi+boxysize
20696           zi=dmod(zi,boxzsize)
20697           if (zi.lt.0) zi=zi+boxzsize
20698
20699         dxi=dc_norm(1,nres+i)
20700         dyi=dc_norm(2,nres+i)
20701         dzi=dc_norm(3,nres+i)
20702         dsci_inv=vbld_inv(i+nres)
20703 !C
20704 !C Calculate SC interaction energy.
20705 !C
20706         do iint=1,nint_gr_nucl(i)
20707 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20708           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20709             ind=ind+1
20710 !            print *,"JESTEM"
20711             itypj=itype(j,2)
20712             if (itypj.eq.ntyp1_molec(2)) cycle
20713             dscj_inv=vbld_inv(j+nres)
20714             sig0ij=sigma_nucl(itypi,itypj)
20715             chi1=chi_nucl(itypi,itypj)
20716             chi2=chi_nucl(itypj,itypi)
20717             chi12=chi1*chi2
20718             chip1=chip_nucl(itypi,itypj)
20719             chip2=chip_nucl(itypj,itypi)
20720             chip12=chip1*chip2
20721 !            xj=c(1,nres+j)-xi
20722 !            yj=c(2,nres+j)-yi
20723 !            zj=c(3,nres+j)-zi
20724            xj=c(1,nres+j)
20725            yj=c(2,nres+j)
20726            zj=c(3,nres+j)
20727           xj=dmod(xj,boxxsize)
20728           if (xj.lt.0) xj=xj+boxxsize
20729           yj=dmod(yj,boxysize)
20730           if (yj.lt.0) yj=yj+boxysize
20731           zj=dmod(zj,boxzsize)
20732           if (zj.lt.0) zj=zj+boxzsize
20733       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20734       xj_safe=xj
20735       yj_safe=yj
20736       zj_safe=zj
20737       subchap=0
20738       do xshift=-1,1
20739       do yshift=-1,1
20740       do zshift=-1,1
20741           xj=xj_safe+xshift*boxxsize
20742           yj=yj_safe+yshift*boxysize
20743           zj=zj_safe+zshift*boxzsize
20744           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20745           if(dist_temp.lt.dist_init) then
20746             dist_init=dist_temp
20747             xj_temp=xj
20748             yj_temp=yj
20749             zj_temp=zj
20750             subchap=1
20751           endif
20752        enddo
20753        enddo
20754        enddo
20755        if (subchap.eq.1) then
20756           xj=xj_temp-xi
20757           yj=yj_temp-yi
20758           zj=zj_temp-zi
20759        else
20760           xj=xj_safe-xi
20761           yj=yj_safe-yi
20762           zj=zj_safe-zi
20763        endif
20764
20765             dxj=dc_norm(1,nres+j)
20766             dyj=dc_norm(2,nres+j)
20767             dzj=dc_norm(3,nres+j)
20768             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20769             rij=dsqrt(rrij)
20770 !C Calculate angle-dependent terms of energy and contributions to their
20771 !C derivatives.
20772             erij(1)=xj*rij
20773             erij(2)=yj*rij
20774             erij(3)=zj*rij
20775             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20776             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20777             om12=dxi*dxj+dyi*dyj+dzi*dzj
20778             call sc_angular_nucl
20779             sigsq=1.0D0/sigsq
20780             sig=sig0ij*dsqrt(sigsq)
20781             rij_shift=1.0D0/rij-sig+sig0ij
20782 !            print *,rij_shift,"rij_shift"
20783 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20784 !c     &       " rij_shift",rij_shift
20785             if (rij_shift.le.0.0D0) then
20786               evdw=1.0D20
20787               return
20788             endif
20789             sigder=-sig*sigsq
20790 !c---------------------------------------------------------------
20791             rij_shift=1.0D0/rij_shift
20792             fac=rij_shift**expon
20793             e1=fac*fac*aa_nucl(itypi,itypj)
20794             e2=fac*bb_nucl(itypi,itypj)
20795             evdwij=eps1*eps2rt*(e1+e2)
20796 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20797 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20798             eps2der=evdwij
20799             evdwij=evdwij*eps2rt
20800             evdwsb=evdwsb+evdwij
20801             if (lprn) then
20802             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
20803             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
20804             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20805              restyp(itypi,2),i,restyp(itypj,2),j, &
20806              epsi,sigm,chi1,chi2,chip1,chip2, &
20807              eps1,eps2rt**2,sig,sig0ij, &
20808              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20809             evdwij
20810             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20811             endif
20812
20813             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20814                              'evdw',i,j,evdwij,"tu3"
20815
20816
20817 !C Calculate gradient components.
20818             e1=e1*eps1*eps2rt**2
20819             fac=-expon*(e1+evdwij)*rij_shift
20820             sigder=fac*sigder
20821             fac=rij*fac
20822 !c            fac=0.0d0
20823 !C Calculate the radial part of the gradient
20824             gg(1)=xj*fac
20825             gg(2)=yj*fac
20826             gg(3)=zj*fac
20827 !C Calculate angular part of the gradient.
20828             call sc_grad_nucl
20829             call eelsbij(eelij,num_conti2)
20830             if (energy_dec .and. &
20831            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20832           write (istat,'(e14.5)') evdwij
20833             eelsb=eelsb+eelij
20834           enddo      ! j
20835         enddo        ! iint
20836         num_cont_hb(i)=num_conti2
20837       enddo          ! i
20838 !c      write (iout,*) "Number of loop steps in EGB:",ind
20839 !cccc      energy_dec=.false.
20840       return
20841       end subroutine esb_gb
20842 !-------------------------------------------------------------------------------
20843       subroutine eelsbij(eesij,num_conti2)
20844       use comm_locel
20845       use calc_data_nucl
20846       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20847       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20848       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20849                     dist_temp, dist_init,rlocshield,fracinbuf
20850       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20851
20852 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20853       real(kind=8) scal_el /0.5d0/
20854       integer :: iteli,itelj,kkk,kkll,m,isubchap
20855       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20856       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20857       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20858                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20859                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20860                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20861                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20862                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20863                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20864                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20865       ind=ind+1
20866       itypi=itype(i,2)
20867       itypj=itype(j,2)
20868 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20869       ael6i=ael6_nucl(itypi,itypj)
20870       ael3i=ael3_nucl(itypi,itypj)
20871       ael63i=ael63_nucl(itypi,itypj)
20872       ael32i=ael32_nucl(itypi,itypj)
20873 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20874 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20875       dxj=dc(1,j+nres)
20876       dyj=dc(2,j+nres)
20877       dzj=dc(3,j+nres)
20878       dx_normi=dc_norm(1,i+nres)
20879       dy_normi=dc_norm(2,i+nres)
20880       dz_normi=dc_norm(3,i+nres)
20881       dx_normj=dc_norm(1,j+nres)
20882       dy_normj=dc_norm(2,j+nres)
20883       dz_normj=dc_norm(3,j+nres)
20884 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20885 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20886 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20887       if (ipot_nucl.ne.2) then
20888         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20889         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20890         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20891       else
20892         cosa=om12
20893         cosb=om1
20894         cosg=om2
20895       endif
20896       r3ij=rij*rrij
20897       r6ij=r3ij*r3ij
20898       fac=cosa-3.0D0*cosb*cosg
20899       facfac=fac*fac
20900       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20901       fac3=ael6i*r6ij
20902       fac4=ael3i*r3ij
20903       fac5=ael63i*r6ij
20904       fac6=ael32i*r6ij
20905 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20906 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20907       el1=fac3*(4.0D0+facfac-fac1)
20908       el2=fac4*fac
20909       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20910       el4=fac6*facfac
20911       eesij=el1+el2+el3+el4
20912 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20913       ees0ij=4.0D0+facfac-fac1
20914
20915       if (energy_dec) then
20916           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20917           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20918            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20919            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20920            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20921           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20922       endif
20923
20924 !C
20925 !C Calculate contributions to the Cartesian gradient.
20926 !C
20927       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20928       fac1=fac
20929 !c      erij(1)=xj*rmij
20930 !c      erij(2)=yj*rmij
20931 !c      erij(3)=zj*rmij
20932 !*
20933 !* Radial derivatives. First process both termini of the fragment (i,j)
20934 !*
20935       ggg(1)=facel*xj
20936       ggg(2)=facel*yj
20937       ggg(3)=facel*zj
20938       do k=1,3
20939         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20940         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20941         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20942         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20943       enddo
20944 !*
20945 !* Angular part
20946 !*
20947       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20948       fac4=-3.0D0*fac4
20949       fac3=-6.0D0*fac3
20950       fac5= 6.0d0*fac5
20951       fac6=-6.0d0*fac6
20952       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20953        fac6*fac1*cosg
20954       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20955        fac6*fac1*cosb
20956       do k=1,3
20957         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20958         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20959       enddo
20960       do k=1,3
20961         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20962       enddo
20963       do k=1,3
20964         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20965              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20966              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20967         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20968              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20969              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20970         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20971         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20972       enddo
20973 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
20974        IF ( j.gt.i+1 .and.&
20975           num_conti.le.maxconts) THEN
20976 !C
20977 !C Calculate the contact function. The ith column of the array JCONT will
20978 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20979 !C greater than I). The arrays FACONT and GACONT will contain the values of
20980 !C the contact function and its derivative.
20981         r0ij=2.20D0*sigma(itypi,itypj)
20982 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20983         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20984 !c        write (2,*) "fcont",fcont
20985         if (fcont.gt.0.0D0) then
20986           num_conti=num_conti+1
20987           num_conti2=num_conti2+1
20988
20989           if (num_conti.gt.maxconts) then
20990             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20991                           ' will skip next contacts for this conf.'
20992           else
20993             jcont_hb(num_conti,i)=j
20994 !c            write (iout,*) "num_conti",num_conti,
20995 !c     &        " jcont_hb",jcont_hb(num_conti,i)
20996 !C Calculate contact energies
20997             cosa4=4.0D0*cosa
20998             wij=cosa-3.0D0*cosb*cosg
20999             cosbg1=cosb+cosg
21000             cosbg2=cosb-cosg
21001             fac3=dsqrt(-ael6i)*r3ij
21002 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21003             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21004             if (ees0tmp.gt.0) then
21005               ees0pij=dsqrt(ees0tmp)
21006             else
21007               ees0pij=0
21008             endif
21009             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21010             if (ees0tmp.gt.0) then
21011               ees0mij=dsqrt(ees0tmp)
21012             else
21013               ees0mij=0
21014             endif
21015             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21016             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21017 !c            write (iout,*) "i",i," j",j,
21018 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21019             ees0pij1=fac3/ees0pij
21020             ees0mij1=fac3/ees0mij
21021             fac3p=-3.0D0*fac3*rrij
21022             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21023             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21024             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21025             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21026             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21027             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21028             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21029             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21030             ecosap=ecosa1+ecosa2
21031             ecosbp=ecosb1+ecosb2
21032             ecosgp=ecosg1+ecosg2
21033             ecosam=ecosa1-ecosa2
21034             ecosbm=ecosb1-ecosb2
21035             ecosgm=ecosg1-ecosg2
21036 !C End diagnostics
21037             facont_hb(num_conti,i)=fcont
21038             fprimcont=fprimcont/rij
21039             do k=1,3
21040               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21041               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21042             enddo
21043             gggp(1)=gggp(1)+ees0pijp*xj
21044             gggp(2)=gggp(2)+ees0pijp*yj
21045             gggp(3)=gggp(3)+ees0pijp*zj
21046             gggm(1)=gggm(1)+ees0mijp*xj
21047             gggm(2)=gggm(2)+ees0mijp*yj
21048             gggm(3)=gggm(3)+ees0mijp*zj
21049 !C Derivatives due to the contact function
21050             gacont_hbr(1,num_conti,i)=fprimcont*xj
21051             gacont_hbr(2,num_conti,i)=fprimcont*yj
21052             gacont_hbr(3,num_conti,i)=fprimcont*zj
21053             do k=1,3
21054 !c
21055 !c Gradient of the correlation terms
21056 !c
21057               gacontp_hb1(k,num_conti,i)= &
21058              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21059             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21060               gacontp_hb2(k,num_conti,i)= &
21061              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21062             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21063               gacontp_hb3(k,num_conti,i)=gggp(k)
21064               gacontm_hb1(k,num_conti,i)= &
21065              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21066             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21067               gacontm_hb2(k,num_conti,i)= &
21068              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21069             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21070               gacontm_hb3(k,num_conti,i)=gggm(k)
21071             enddo
21072           endif
21073         endif
21074       ENDIF
21075       return
21076       end subroutine eelsbij
21077 !------------------------------------------------------------------
21078       subroutine sc_grad_nucl
21079       use comm_locel
21080       use calc_data_nucl
21081       real(kind=8),dimension(3) :: dcosom1,dcosom2
21082       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21083       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21084       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21085       do k=1,3
21086         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21087         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21088       enddo
21089       do k=1,3
21090         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21091       enddo
21092       do k=1,3
21093         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21094                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21095                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21096         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21097                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21098                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21099       enddo
21100 !C
21101 !C Calculate the components of the gradient in DC and X
21102 !C
21103       do l=1,3
21104         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21105         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21106       enddo
21107       return
21108       end subroutine sc_grad_nucl
21109 !-----------------------------------------------------------------------
21110       subroutine esb(esbloc)
21111 !C Calculate the local energy of a side chain and its derivatives in the
21112 !C corresponding virtual-bond valence angles THETA and the spherical angles
21113 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21114 !C added by Urszula Kozlowska. 07/11/2007
21115 !C
21116       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21117       real(kind=8),dimension(9):: x
21118      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21119       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21120       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21121       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21122        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21123        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21124        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21125        integer::it,nlobit,i,j,k
21126 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21127       delta=0.02d0*pi
21128       esbloc=0.0D0
21129       do i=loc_start_nucl,loc_end_nucl
21130         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21131         costtab(i+1) =dcos(theta(i+1))
21132         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21133         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21134         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21135         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21136         cosfac=dsqrt(cosfac2)
21137         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21138         sinfac=dsqrt(sinfac2)
21139         it=itype(i,2)
21140         if (it.eq.10) goto 1
21141
21142 !c
21143 !C  Compute the axes of tghe local cartesian coordinates system; store in
21144 !c   x_prime, y_prime and z_prime
21145 !c
21146         do j=1,3
21147           x_prime(j) = 0.00
21148           y_prime(j) = 0.00
21149           z_prime(j) = 0.00
21150         enddo
21151 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21152 !C     &   dc_norm(3,i+nres)
21153         do j = 1,3
21154           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21155           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21156         enddo
21157         do j = 1,3
21158           z_prime(j) = -uz(j,i-1)
21159 !           z_prime(j)=0.0
21160         enddo
21161
21162         xx=0.0d0
21163         yy=0.0d0
21164         zz=0.0d0
21165         do j = 1,3
21166           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21167           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21168           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21169         enddo
21170
21171         xxtab(i)=xx
21172         yytab(i)=yy
21173         zztab(i)=zz
21174          it=itype(i,2)
21175         do j = 1,9
21176           x(j) = sc_parmin_nucl(j,it)
21177         enddo
21178 #ifdef CHECK_COORD
21179 !Cc diagnostics - remove later
21180         xx1 = dcos(alph(2))
21181         yy1 = dsin(alph(2))*dcos(omeg(2))
21182         zz1 = -dsin(alph(2))*dsin(omeg(2))
21183         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21184          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21185          xx1,yy1,zz1
21186 !C,"  --- ", xx_w,yy_w,zz_w
21187 !c end diagnostics
21188 #endif
21189         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21190         esbloc = esbloc + sumene
21191         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21192 !        print *,"enecomp",sumene,sumene2
21193 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21194 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21195 #ifdef DEBUG
21196         write (2,*) "x",(x(k),k=1,9)
21197 !C
21198 !C This section to check the numerical derivatives of the energy of ith side
21199 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21200 !C #define DEBUG in the code to turn it on.
21201 !C
21202         write (2,*) "sumene               =",sumene
21203         aincr=1.0d-7
21204         xxsave=xx
21205         xx=xx+aincr
21206         write (2,*) xx,yy,zz
21207         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21208         de_dxx_num=(sumenep-sumene)/aincr
21209         xx=xxsave
21210         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21211         yysave=yy
21212         yy=yy+aincr
21213         write (2,*) xx,yy,zz
21214         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21215         de_dyy_num=(sumenep-sumene)/aincr
21216         yy=yysave
21217         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21218         zzsave=zz
21219         zz=zz+aincr
21220         write (2,*) xx,yy,zz
21221         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21222         de_dzz_num=(sumenep-sumene)/aincr
21223         zz=zzsave
21224         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21225         costsave=cost2tab(i+1)
21226         sintsave=sint2tab(i+1)
21227         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21228         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21229         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21230         de_dt_num=(sumenep-sumene)/aincr
21231         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21232         cost2tab(i+1)=costsave
21233         sint2tab(i+1)=sintsave
21234 !C End of diagnostics section.
21235 #endif
21236 !C
21237 !C Compute the gradient of esc
21238 !C
21239         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21240         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21241         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21242         de_dtt=0.0d0
21243 #ifdef DEBUG
21244         write (2,*) "x",(x(k),k=1,9)
21245         write (2,*) "xx",xx," yy",yy," zz",zz
21246         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21247           " de_zz   ",de_zz," de_tt   ",de_tt
21248         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21249           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21250 #endif
21251 !C
21252        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21253        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21254        cosfac2xx=cosfac2*xx
21255        sinfac2yy=sinfac2*yy
21256        do k = 1,3
21257          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21258            vbld_inv(i+1)
21259          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21260            vbld_inv(i)
21261          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21262          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21263 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21264 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21265 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21266 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21267          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21268          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21269          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21270          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21271          dZZ_Ci1(k)=0.0d0
21272          dZZ_Ci(k)=0.0d0
21273          do j=1,3
21274            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21275            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21276          enddo
21277
21278          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21279          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21280          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21281 !c
21282          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21283          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21284        enddo
21285
21286        do k=1,3
21287          dXX_Ctab(k,i)=dXX_Ci(k)
21288          dXX_C1tab(k,i)=dXX_Ci1(k)
21289          dYY_Ctab(k,i)=dYY_Ci(k)
21290          dYY_C1tab(k,i)=dYY_Ci1(k)
21291          dZZ_Ctab(k,i)=dZZ_Ci(k)
21292          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21293          dXX_XYZtab(k,i)=dXX_XYZ(k)
21294          dYY_XYZtab(k,i)=dYY_XYZ(k)
21295          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21296        enddo
21297        do k = 1,3
21298 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21299 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21300 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21301 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21302 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21303 !c     &    dt_dci(k)
21304 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21305 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21306          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21307          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21308          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21309          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21310          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21311          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21312 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21313        enddo
21314 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21315 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21316
21317 !C to check gradient call subroutine check_grad
21318
21319     1 continue
21320       enddo
21321       return
21322       end subroutine esb
21323 !=-------------------------------------------------------
21324       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21325 !      implicit none
21326       real(kind=8),dimension(9):: x(9)
21327        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21328       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21329       integer i
21330 !c      write (2,*) "enesc"
21331 !c      write (2,*) "x",(x(i),i=1,9)
21332 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21333       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21334         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21335         + x(9)*yy*zz
21336       enesc_nucl=sumene
21337       return
21338       end function enesc_nucl
21339 !-----------------------------------------------------------------------------
21340       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21341 #ifdef MPI
21342       include 'mpif.h'
21343       integer,parameter :: max_cont=2000
21344       integer,parameter:: max_dim=2*(8*3+6)
21345       integer, parameter :: msglen1=max_cont*max_dim
21346       integer,parameter :: msglen2=2*msglen1
21347       integer source,CorrelType,CorrelID,Error
21348       real(kind=8) :: buffer(max_cont,max_dim)
21349       integer status(MPI_STATUS_SIZE)
21350       integer :: ierror,nbytes
21351 #endif
21352       real(kind=8),dimension(3):: gx(3),gx1(3)
21353       real(kind=8) :: time00
21354       logical lprn,ldone
21355       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21356       real(kind=8) ecorr,ecorr3
21357       integer :: n_corr,n_corr1,mm,msglen
21358 !C Set lprn=.true. for debugging
21359       lprn=.false.
21360       n_corr=0
21361       n_corr1=0
21362 #ifdef MPI
21363       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21364
21365       if (nfgtasks.le.1) goto 30
21366       if (lprn) then
21367         write (iout,'(a)') 'Contact function values:'
21368         do i=nnt,nct-1
21369           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21370          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21371          j=1,num_cont_hb(i))
21372         enddo
21373       endif
21374 !C Caution! Following code assumes that electrostatic interactions concerning
21375 !C a given atom are split among at most two processors!
21376       CorrelType=477
21377       CorrelID=fg_rank+1
21378       ldone=.false.
21379       do i=1,max_cont
21380         do j=1,max_dim
21381           buffer(i,j)=0.0D0
21382         enddo
21383       enddo
21384       mm=mod(fg_rank,2)
21385 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21386       if (mm) 20,20,10
21387    10 continue
21388 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21389       if (fg_rank.gt.0) then
21390 !C Send correlation contributions to the preceding processor
21391         msglen=msglen1
21392         nn=num_cont_hb(iatel_s_nucl)
21393         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21394 !c        write (*,*) 'The BUFFER array:'
21395 !c        do i=1,nn
21396 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21397 !c        enddo
21398         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21399           msglen=msglen2
21400           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21401 !C Clear the contacts of the atom passed to the neighboring processor
21402         nn=num_cont_hb(iatel_s_nucl+1)
21403 !c        do i=1,nn
21404 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21405 !c        enddo
21406             num_cont_hb(iatel_s_nucl)=0
21407         endif
21408 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21409 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21410 !cd   & ' msglen=',msglen
21411 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21412 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21413 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21414         time00=MPI_Wtime()
21415         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21416          CorrelType,FG_COMM,IERROR)
21417         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21418 !cd      write (iout,*) 'Processor ',fg_rank,
21419 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21420 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21421 !c        write (*,*) 'Processor ',fg_rank,
21422 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21423 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21424 !c        msglen=msglen1
21425       endif ! (fg_rank.gt.0)
21426       if (ldone) goto 30
21427       ldone=.true.
21428    20 continue
21429 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21430       if (fg_rank.lt.nfgtasks-1) then
21431 !C Receive correlation contributions from the next processor
21432         msglen=msglen1
21433         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21434 !cd      write (iout,*) 'Processor',fg_rank,
21435 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21436 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21437 !c        write (*,*) 'Processor',fg_rank,
21438 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21439 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21440         time00=MPI_Wtime()
21441         nbytes=-1
21442         do while (nbytes.le.0)
21443           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21444           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21445         enddo
21446 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21447         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21448          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21449         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21450 !c        write (*,*) 'Processor',fg_rank,
21451 !c     &' has received correlation contribution from processor',fg_rank+1,
21452 !c     & ' msglen=',msglen,' nbytes=',nbytes
21453 !c        write (*,*) 'The received BUFFER array:'
21454 !c        do i=1,max_cont
21455 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21456 !c        enddo
21457         if (msglen.eq.msglen1) then
21458           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21459         else if (msglen.eq.msglen2)  then
21460           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21461           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21462         else
21463           write (iout,*) &
21464       'ERROR!!!! message length changed while processing correlations.'
21465           write (*,*) &
21466       'ERROR!!!! message length changed while processing correlations.'
21467           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21468         endif ! msglen.eq.msglen1
21469       endif ! fg_rank.lt.nfgtasks-1
21470       if (ldone) goto 30
21471       ldone=.true.
21472       goto 10
21473    30 continue
21474 #endif
21475       if (lprn) then
21476         write (iout,'(a)') 'Contact function values:'
21477         do i=nnt_molec(2),nct_molec(2)-1
21478           write (iout,'(2i3,50(1x,i2,f5.2))') &
21479          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21480          j=1,num_cont_hb(i))
21481         enddo
21482       endif
21483       ecorr=0.0D0
21484       ecorr3=0.0d0
21485 !C Remove the loop below after debugging !!!
21486 !      do i=nnt_molec(2),nct_molec(2)
21487 !        do j=1,3
21488 !          gradcorr_nucl(j,i)=0.0D0
21489 !          gradxorr_nucl(j,i)=0.0D0
21490 !          gradcorr3_nucl(j,i)=0.0D0
21491 !          gradxorr3_nucl(j,i)=0.0D0
21492 !        enddo
21493 !      enddo
21494 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21495 !C Calculate the local-electrostatic correlation terms
21496       do i=iatsc_s_nucl,iatsc_e_nucl
21497         i1=i+1
21498         num_conti=num_cont_hb(i)
21499         num_conti1=num_cont_hb(i+1)
21500 !        print *,i,num_conti,num_conti1
21501         do jj=1,num_conti
21502           j=jcont_hb(jj,i)
21503           do kk=1,num_conti1
21504             j1=jcont_hb(kk,i1)
21505 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21506 !c     &         ' jj=',jj,' kk=',kk
21507             if (j1.eq.j+1 .or. j1.eq.j-1) then
21508 !C
21509 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21510 !C The system gains extra energy.
21511 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21512 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21513 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21514 !C
21515               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21516               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21517                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21518               n_corr=n_corr+1
21519             else if (j1.eq.j) then
21520 !C
21521 !C Contacts I-J and I-(J+1) occur simultaneously.
21522 !C The system loses extra energy.
21523 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21524 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21525 !C Need to implement full formulas 32 from Liwo et al., 1998.
21526 !C
21527 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21528 !c     &         ' jj=',jj,' kk=',kk
21529               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21530             endif
21531           enddo ! kk
21532           do kk=1,num_conti
21533             j1=jcont_hb(kk,i)
21534 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21535 !c     &         ' jj=',jj,' kk=',kk
21536             if (j1.eq.j+1) then
21537 !C Contacts I-J and (I+1)-J occur simultaneously.
21538 !C The system loses extra energy.
21539               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21540             endif ! j1==j+1
21541           enddo ! kk
21542         enddo ! jj
21543       enddo ! i
21544       return
21545       end subroutine multibody_hb_nucl
21546 !-----------------------------------------------------------
21547       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21548 !      implicit real*8 (a-h,o-z)
21549 !      include 'DIMENSIONS'
21550 !      include 'COMMON.IOUNITS'
21551 !      include 'COMMON.DERIV'
21552 !      include 'COMMON.INTERACT'
21553 !      include 'COMMON.CONTACTS'
21554       real(kind=8),dimension(3) :: gx,gx1
21555       logical :: lprn
21556 !el local variables
21557       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21558       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21559                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21560                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21561                    rlocshield
21562
21563       lprn=.false.
21564       eij=facont_hb(jj,i)
21565       ekl=facont_hb(kk,k)
21566       ees0pij=ees0p(jj,i)
21567       ees0pkl=ees0p(kk,k)
21568       ees0mij=ees0m(jj,i)
21569       ees0mkl=ees0m(kk,k)
21570       ekont=eij*ekl
21571       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21572 !      print *,"ehbcorr_nucl",ekont,ees
21573 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21574 !C Following 4 lines for diagnostics.
21575 !cd    ees0pkl=0.0D0
21576 !cd    ees0pij=1.0D0
21577 !cd    ees0mkl=0.0D0
21578 !cd    ees0mij=1.0D0
21579 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21580 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21581 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21582 !C Calculate the multi-body contribution to energy.
21583 !      ecorr_nucl=ecorr_nucl+ekont*ees
21584 !C Calculate multi-body contributions to the gradient.
21585       coeffpees0pij=coeffp*ees0pij
21586       coeffmees0mij=coeffm*ees0mij
21587       coeffpees0pkl=coeffp*ees0pkl
21588       coeffmees0mkl=coeffm*ees0mkl
21589       do ll=1,3
21590         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21591        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21592        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21593         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21594         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21595         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21596         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21597         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21598         coeffmees0mij*gacontm_hb1(ll,kk,k))
21599         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21600         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21601         coeffmees0mij*gacontm_hb2(ll,kk,k))
21602         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21603           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21604           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21605         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21606         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21607         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21608           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21609           coeffmees0mij*gacontm_hb3(ll,kk,k))
21610         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21611         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21612         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21613         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21614         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21615         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21616       enddo
21617       ehbcorr_nucl=ekont*ees
21618       return
21619       end function ehbcorr_nucl
21620 !-------------------------------------------------------------------------
21621
21622      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21623 !      implicit real*8 (a-h,o-z)
21624 !      include 'DIMENSIONS'
21625 !      include 'COMMON.IOUNITS'
21626 !      include 'COMMON.DERIV'
21627 !      include 'COMMON.INTERACT'
21628 !      include 'COMMON.CONTACTS'
21629       real(kind=8),dimension(3) :: gx,gx1
21630       logical :: lprn
21631 !el local variables
21632       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21633       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21634                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21635                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21636                    rlocshield
21637
21638       lprn=.false.
21639       eij=facont_hb(jj,i)
21640       ekl=facont_hb(kk,k)
21641       ees0pij=ees0p(jj,i)
21642       ees0pkl=ees0p(kk,k)
21643       ees0mij=ees0m(jj,i)
21644       ees0mkl=ees0m(kk,k)
21645       ekont=eij*ekl
21646       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21647 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21648 !C Following 4 lines for diagnostics.
21649 !cd    ees0pkl=0.0D0
21650 !cd    ees0pij=1.0D0
21651 !cd    ees0mkl=0.0D0
21652 !cd    ees0mij=1.0D0
21653 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21654 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21655 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21656 !C Calculate the multi-body contribution to energy.
21657 !      ecorr=ecorr+ekont*ees
21658 !C Calculate multi-body contributions to the gradient.
21659       coeffpees0pij=coeffp*ees0pij
21660       coeffmees0mij=coeffm*ees0mij
21661       coeffpees0pkl=coeffp*ees0pkl
21662       coeffmees0mkl=coeffm*ees0mkl
21663       do ll=1,3
21664         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21665        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21666        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21667         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21668         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21669         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21670         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21671         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21672         coeffmees0mij*gacontm_hb1(ll,kk,k))
21673         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21674         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21675         coeffmees0mij*gacontm_hb2(ll,kk,k))
21676         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21677           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21678           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21679         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21680         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21681         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21682           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21683           coeffmees0mij*gacontm_hb3(ll,kk,k))
21684         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21685         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21686         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21687         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21688         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21689         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21690       enddo
21691       ehbcorr3_nucl=ekont*ees
21692       return
21693       end function ehbcorr3_nucl
21694 #ifdef MPI
21695       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21696       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21697       real(kind=8):: buffer(dimen1,dimen2)
21698       num_kont=num_cont_hb(atom)
21699       do i=1,num_kont
21700         do k=1,8
21701           do j=1,3
21702             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21703           enddo ! j
21704         enddo ! k
21705         buffer(i,indx+25)=facont_hb(i,atom)
21706         buffer(i,indx+26)=ees0p(i,atom)
21707         buffer(i,indx+27)=ees0m(i,atom)
21708         buffer(i,indx+28)=d_cont(i,atom)
21709         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21710       enddo ! i
21711       buffer(1,indx+30)=dfloat(num_kont)
21712       return
21713       end subroutine pack_buffer
21714 !c------------------------------------------------------------------------------
21715       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21716       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21717       real(kind=8):: buffer(dimen1,dimen2)
21718 !      double precision zapas
21719 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21720 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21721 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21722 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21723       num_kont=buffer(1,indx+30)
21724       num_kont_old=num_cont_hb(atom)
21725       num_cont_hb(atom)=num_kont+num_kont_old
21726       do i=1,num_kont
21727         ii=i+num_kont_old
21728         do k=1,8
21729           do j=1,3
21730             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21731           enddo ! j
21732         enddo ! k
21733         facont_hb(ii,atom)=buffer(i,indx+25)
21734         ees0p(ii,atom)=buffer(i,indx+26)
21735         ees0m(ii,atom)=buffer(i,indx+27)
21736         d_cont(i,atom)=buffer(i,indx+28)
21737         jcont_hb(ii,atom)=buffer(i,indx+29)
21738       enddo ! i
21739       return
21740       end subroutine unpack_buffer
21741 !c------------------------------------------------------------------------------
21742 #endif
21743       subroutine ecatcat(ecationcation)
21744         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21745         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21746         r7,r4,ecationcation,k0,rcal
21747         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21748         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21749         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21750         gg,r
21751
21752         ecationcation=0.0d0
21753         if (nres_molec(5).eq.0) return
21754         rcat0=3.472
21755         epscalc=0.05
21756         r06 = rcat0**6
21757         r012 = r06**2
21758         k0 = 332.0*(2.0*2.0)/80.0
21759         itmp=0
21760         do i=1,4
21761         itmp=itmp+nres_molec(i)
21762         enddo
21763         do i=itmp+1,itmp+nres_molec(5)-1
21764
21765         xi=c(1,i)
21766         yi=c(2,i)
21767         zi=c(3,i)
21768           xi=mod(xi,boxxsize)
21769           if (xi.lt.0) xi=xi+boxxsize
21770           yi=mod(yi,boxysize)
21771           if (yi.lt.0) yi=yi+boxysize
21772           zi=mod(zi,boxzsize)
21773           if (zi.lt.0) zi=zi+boxzsize
21774
21775           do j=i+1,itmp+nres_molec(5)
21776 !           print *,i,j,'catcat'
21777            xj=c(1,j)
21778            yj=c(2,j)
21779            zj=c(3,j)
21780           xj=dmod(xj,boxxsize)
21781           if (xj.lt.0) xj=xj+boxxsize
21782           yj=dmod(yj,boxysize)
21783           if (yj.lt.0) yj=yj+boxysize
21784           zj=dmod(zj,boxzsize)
21785           if (zj.lt.0) zj=zj+boxzsize
21786       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21787       xj_safe=xj
21788       yj_safe=yj
21789       zj_safe=zj
21790       subchap=0
21791       do xshift=-1,1
21792       do yshift=-1,1
21793       do zshift=-1,1
21794           xj=xj_safe+xshift*boxxsize
21795           yj=yj_safe+yshift*boxysize
21796           zj=zj_safe+zshift*boxzsize
21797           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21798           if(dist_temp.lt.dist_init) then
21799             dist_init=dist_temp
21800             xj_temp=xj
21801             yj_temp=yj
21802             zj_temp=zj
21803             subchap=1
21804           endif
21805        enddo
21806        enddo
21807        enddo
21808        if (subchap.eq.1) then
21809           xj=xj_temp-xi
21810           yj=yj_temp-yi
21811           zj=zj_temp-zi
21812        else
21813           xj=xj_safe-xi
21814           yj=yj_safe-yi
21815           zj=zj_safe-zi
21816        endif
21817        rcal =xj**2+yj**2+zj**2
21818         ract=sqrt(rcal)
21819 !        rcat0=3.472
21820 !        epscalc=0.05
21821 !        r06 = rcat0**6
21822 !        r012 = r06**2
21823 !        k0 = 332*(2*2)/80
21824         Evan1cat=epscalc*(r012/rcal**6)
21825         Evan2cat=epscalc*2*(r06/rcal**3)
21826         Eeleccat=k0/ract
21827         r7 = rcal**7
21828         r4 = rcal**4
21829         r(1)=xj
21830         r(2)=yj
21831         r(3)=zj
21832         do k=1,3
21833           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21834           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21835           dEeleccat(k)=-k0*r(k)/ract**3
21836         enddo
21837         do k=1,3
21838           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21839           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
21840           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
21841         enddo
21842
21843         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
21844        enddo
21845        enddo
21846        return
21847        end subroutine ecatcat
21848 !---------------------------------------------------------------------------
21849        subroutine ecat_prot(ecation_prot)
21850        integer i,j,k,subchap,itmp,inum
21851         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21852         r7,r4,ecationcation
21853         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21854         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
21855         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
21856         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
21857         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
21858         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
21859         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
21860         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
21861         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
21862         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
21863         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
21864         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21865         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
21866         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
21867         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
21868         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
21869         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
21870         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
21871         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
21872         dEvan1Cat
21873         real(kind=8),dimension(6) :: vcatprm
21874         ecation_prot=0.0d0
21875 ! first lets calculate interaction with peptide groups
21876         if (nres_molec(5).eq.0) return
21877          wconst=78
21878         wdip =1.092777950857032D2
21879         wdip=wdip/wconst
21880         wmodquad=-2.174122713004870D4
21881         wmodquad=wmodquad/wconst
21882         wquad1 = 3.901232068562804D1
21883         wquad1=wquad1/wconst
21884         wquad2 = 3
21885         wquad2=wquad2/wconst
21886         wvan1 = 0.1
21887         wvan2 = 6
21888         itmp=0
21889         do i=1,4
21890         itmp=itmp+nres_molec(i)
21891         enddo
21892 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
21893         do i=ibond_start,ibond_end
21894 !         cycle
21895          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
21896         xi=0.5d0*(c(1,i)+c(1,i+1))
21897         yi=0.5d0*(c(2,i)+c(2,i+1))
21898         zi=0.5d0*(c(3,i)+c(3,i+1))
21899           xi=mod(xi,boxxsize)
21900           if (xi.lt.0) xi=xi+boxxsize
21901           yi=mod(yi,boxysize)
21902           if (yi.lt.0) yi=yi+boxysize
21903           zi=mod(zi,boxzsize)
21904           if (zi.lt.0) zi=zi+boxzsize
21905
21906          do j=itmp+1,itmp+nres_molec(5)
21907            xj=c(1,j)
21908            yj=c(2,j)
21909            zj=c(3,j)
21910           xj=dmod(xj,boxxsize)
21911           if (xj.lt.0) xj=xj+boxxsize
21912           yj=dmod(yj,boxysize)
21913           if (yj.lt.0) yj=yj+boxysize
21914           zj=dmod(zj,boxzsize)
21915           if (zj.lt.0) zj=zj+boxzsize
21916       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21917       xj_safe=xj
21918       yj_safe=yj
21919       zj_safe=zj
21920       subchap=0
21921       do xshift=-1,1
21922       do yshift=-1,1
21923       do zshift=-1,1
21924           xj=xj_safe+xshift*boxxsize
21925           yj=yj_safe+yshift*boxysize
21926           zj=zj_safe+zshift*boxzsize
21927           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21928           if(dist_temp.lt.dist_init) then
21929             dist_init=dist_temp
21930             xj_temp=xj
21931             yj_temp=yj
21932             zj_temp=zj
21933             subchap=1
21934           endif
21935        enddo
21936        enddo
21937        enddo
21938        if (subchap.eq.1) then
21939           xj=xj_temp-xi
21940           yj=yj_temp-yi
21941           zj=zj_temp-zi
21942        else
21943           xj=xj_safe-xi
21944           yj=yj_safe-yi
21945           zj=zj_safe-zi
21946        endif
21947 !       enddo
21948 !       enddo
21949        rcpm = sqrt(xj**2+yj**2+zj**2)
21950        drcp_norm(1)=xj/rcpm
21951        drcp_norm(2)=yj/rcpm
21952        drcp_norm(3)=zj/rcpm
21953        dcmag=0.0
21954        do k=1,3
21955        dcmag=dcmag+dc(k,i)**2
21956        enddo
21957        dcmag=dsqrt(dcmag)
21958        do k=1,3
21959          myd_norm(k)=dc(k,i)/dcmag
21960        enddo
21961         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
21962         drcp_norm(3)*myd_norm(3)
21963         rsecp = rcpm**2
21964         Ir = 1.0d0/rcpm
21965         Irsecp = 1.0d0/rsecp
21966         Irthrp = Irsecp/rcpm
21967         Irfourp = Irthrp/rcpm
21968         Irfiftp = Irfourp/rcpm
21969         Irsistp=Irfiftp/rcpm
21970         Irseven=Irsistp/rcpm
21971         Irtwelv=Irsistp*Irsistp
21972         Irthir=Irtwelv/rcpm
21973         sin2thet = (1-costhet*costhet)
21974         sinthet=sqrt(sin2thet)
21975         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
21976              *sin2thet
21977         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
21978              2*wvan2**6*Irsistp)
21979         ecation_prot = ecation_prot+E1+E2
21980         dE1dr = -2*costhet*wdip*Irthrp-&
21981          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
21982         dE2dr = 3*wquad1*wquad2*Irfourp-     &
21983           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
21984         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
21985         do k=1,3
21986           drdpep(k) = -drcp_norm(k)
21987           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
21988           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
21989           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
21990           dEddci(k) = dEdcos*dcosddci(k)
21991         enddo
21992         do k=1,3
21993         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
21994         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
21995         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
21996         enddo
21997        enddo ! j
21998        enddo ! i
21999 !------------------------------------------sidechains
22000 !        do i=1,nres_molec(1)
22001         do i=ibond_start,ibond_end
22002          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22003 !         cycle
22004 !        print *,i,ecation_prot
22005         xi=(c(1,i+nres))
22006         yi=(c(2,i+nres))
22007         zi=(c(3,i+nres))
22008           xi=mod(xi,boxxsize)
22009           if (xi.lt.0) xi=xi+boxxsize
22010           yi=mod(yi,boxysize)
22011           if (yi.lt.0) yi=yi+boxysize
22012           zi=mod(zi,boxzsize)
22013           if (zi.lt.0) zi=zi+boxzsize
22014           do k=1,3
22015             cm1(k)=dc(k,i+nres)
22016           enddo
22017            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22018          do j=itmp+1,itmp+nres_molec(5)
22019            xj=c(1,j)
22020            yj=c(2,j)
22021            zj=c(3,j)
22022           xj=dmod(xj,boxxsize)
22023           if (xj.lt.0) xj=xj+boxxsize
22024           yj=dmod(yj,boxysize)
22025           if (yj.lt.0) yj=yj+boxysize
22026           zj=dmod(zj,boxzsize)
22027           if (zj.lt.0) zj=zj+boxzsize
22028       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22029       xj_safe=xj
22030       yj_safe=yj
22031       zj_safe=zj
22032       subchap=0
22033       do xshift=-1,1
22034       do yshift=-1,1
22035       do zshift=-1,1
22036           xj=xj_safe+xshift*boxxsize
22037           yj=yj_safe+yshift*boxysize
22038           zj=zj_safe+zshift*boxzsize
22039           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22040           if(dist_temp.lt.dist_init) then
22041             dist_init=dist_temp
22042             xj_temp=xj
22043             yj_temp=yj
22044             zj_temp=zj
22045             subchap=1
22046           endif
22047        enddo
22048        enddo
22049        enddo
22050        if (subchap.eq.1) then
22051           xj=xj_temp-xi
22052           yj=yj_temp-yi
22053           zj=zj_temp-zi
22054        else
22055           xj=xj_safe-xi
22056           yj=yj_safe-yi
22057           zj=zj_safe-zi
22058        endif
22059 !       enddo
22060 !       enddo
22061          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22062             if(itype(i,1).eq.16) then
22063             inum=1
22064             else
22065             inum=2
22066             endif
22067             do k=1,6
22068             vcatprm(k)=catprm(k,inum)
22069             enddo
22070             dASGL=catprm(7,inum)
22071              do k=1,3
22072                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22073                 valpha(k)=c(k,i)
22074                 vcat(k)=c(k,j)
22075               enddo
22076                       do k=1,3
22077           dx(k) = vcat(k)-vcm(k)
22078         enddo
22079         do k=1,3
22080           v1(k)=(vcm(k)-valpha(k))
22081           v2(k)=(vcat(k)-valpha(k))
22082         enddo
22083         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22084         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22085         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22086
22087 !  The weights of the energy function calculated from
22088 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22089         wh2o=78
22090         wc = vcatprm(1)
22091         wc=wc/wh2o
22092         wdip =vcatprm(2)
22093         wdip=wdip/wh2o
22094         wquad1 =vcatprm(3)
22095         wquad1=wquad1/wh2o
22096         wquad2 = vcatprm(4)
22097         wquad2=wquad2/wh2o
22098         wquad2p = 1-wquad2
22099         wvan1 = vcatprm(5)
22100         wvan2 =vcatprm(6)
22101         opt = dx(1)**2+dx(2)**2
22102         rsecp = opt+dx(3)**2
22103         rs = sqrt(rsecp)
22104         rthrp = rsecp*rs
22105         rfourp = rthrp*rs
22106         rsixp = rfourp*rsecp
22107         reight=rsixp*rsecp
22108         Ir = 1.0d0/rs
22109         Irsecp = 1/rsecp
22110         Irthrp = Irsecp/rs
22111         Irfourp = Irthrp/rs
22112         Irsixp = 1/rsixp
22113         Ireight=1/reight
22114         Irtw=Irsixp*Irsixp
22115         Irthir=Irtw/rs
22116         Irfourt=Irthir/rs
22117         opt1 = (4*rs*dx(3)*wdip)
22118         opt2 = 6*rsecp*wquad1*opt
22119         opt3 = wquad1*wquad2p*Irsixp
22120         opt4 = (wvan1*wvan2**12)
22121         opt5 = opt4*12*Irfourt
22122         opt6 = 2*wvan1*wvan2**6
22123         opt7 = 6*opt6*Ireight
22124         opt8 = wdip/v1m
22125         opt10 = wdip/v2m
22126         opt11 = (rsecp*v2m)**2
22127         opt12 = (rsecp*v1m)**2
22128         opt14 = (v1m*v2m*rsecp)**2
22129         opt15 = -wquad1/v2m**2
22130         opt16 = (rthrp*(v1m*v2m)**2)**2
22131         opt17 = (v1m**2*rthrp)**2
22132         opt18 = -wquad1/rthrp
22133         opt19 = (v1m**2*v2m**2)**2
22134         Ec = wc*Ir
22135         do k=1,3
22136           dEcCat(k) = -(dx(k)*wc)*Irthrp
22137           dEcCm(k)=(dx(k)*wc)*Irthrp
22138           dEcCalp(k)=0.0d0
22139         enddo
22140         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22141         do k=1,3
22142           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22143                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22144           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22145                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22146           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22147                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22148                       *v1dpv2)/opt14
22149         enddo
22150         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22151         do k=1,3
22152           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22153                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22154                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22155           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22156                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22157                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22158           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22159                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22160                         v1dpv2**2)/opt19
22161         enddo
22162         Equad2=wquad1*wquad2p*Irthrp
22163         do k=1,3
22164           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22165           dEquad2Cm(k)=3*dx(k)*rs*opt3
22166           dEquad2Calp(k)=0.0d0
22167         enddo
22168         Evan1=opt4*Irtw
22169         do k=1,3
22170           dEvan1Cat(k)=-dx(k)*opt5
22171           dEvan1Cm(k)=dx(k)*opt5
22172           dEvan1Calp(k)=0.0d0
22173         enddo
22174         Evan2=-opt6*Irsixp
22175         do k=1,3
22176           dEvan2Cat(k)=dx(k)*opt7
22177           dEvan2Cm(k)=-dx(k)*opt7
22178           dEvan2Calp(k)=0.0d0
22179         enddo
22180         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22181 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22182
22183         do k=1,3
22184           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22185                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22186 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22187           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22188                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22189           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22190                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22191         enddo
22192             dscmag = 0.0d0
22193             do k=1,3
22194               dscvec(k) = dc(k,i+nres)
22195               dscmag = dscmag+dscvec(k)*dscvec(k)
22196             enddo
22197             dscmag3 = dscmag
22198             dscmag = sqrt(dscmag)
22199             dscmag3 = dscmag3*dscmag
22200             constA = 1.0d0+dASGL/dscmag
22201             constB = 0.0d0
22202             do k=1,3
22203               constB = constB+dscvec(k)*dEtotalCm(k)
22204             enddo
22205             constB = constB*dASGL/dscmag3
22206             do k=1,3
22207               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22208               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22209                constA*dEtotalCm(k)-constB*dscvec(k)
22210 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22211               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22212               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22213              enddo
22214         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22215            if(itype(i,1).eq.14) then
22216             inum=3
22217             else
22218             inum=4
22219             endif
22220             do k=1,6
22221             vcatprm(k)=catprm(k,inum)
22222             enddo
22223             dASGL=catprm(7,inum)
22224              do k=1,3
22225                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22226                 valpha(k)=c(k,i)
22227                 vcat(k)=c(k,j)
22228               enddo
22229
22230         do k=1,3
22231           dx(k) = vcat(k)-vcm(k)
22232         enddo
22233         do k=1,3
22234           v1(k)=(vcm(k)-valpha(k))
22235           v2(k)=(vcat(k)-valpha(k))
22236         enddo
22237         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22238         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22239         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22240 !  The weights of the energy function calculated from
22241 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22242         wh2o=78
22243         wdip =vcatprm(2)
22244         wdip=wdip/wh2o
22245         wquad1 =vcatprm(3)
22246         wquad1=wquad1/wh2o
22247         wquad2 = vcatprm(4)
22248         wquad2=wquad2/wh2o
22249         wquad2p = 1-wquad2
22250         wvan1 = vcatprm(5)
22251         wvan2 =vcatprm(6)
22252         opt = dx(1)**2+dx(2)**2
22253         rsecp = opt+dx(3)**2
22254         rs = sqrt(rsecp)
22255         rthrp = rsecp*rs
22256         rfourp = rthrp*rs
22257         rsixp = rfourp*rsecp
22258         reight=rsixp*rsecp
22259         Ir = 1.0d0/rs
22260         Irsecp = 1/rsecp
22261         Irthrp = Irsecp/rs
22262         Irfourp = Irthrp/rs
22263         Irsixp = 1/rsixp
22264         Ireight=1/reight
22265         Irtw=Irsixp*Irsixp
22266         Irthir=Irtw/rs
22267         Irfourt=Irthir/rs
22268         opt1 = (4*rs*dx(3)*wdip)
22269         opt2 = 6*rsecp*wquad1*opt
22270         opt3 = wquad1*wquad2p*Irsixp
22271         opt4 = (wvan1*wvan2**12)
22272         opt5 = opt4*12*Irfourt
22273         opt6 = 2*wvan1*wvan2**6
22274         opt7 = 6*opt6*Ireight
22275         opt8 = wdip/v1m
22276         opt10 = wdip/v2m
22277         opt11 = (rsecp*v2m)**2
22278         opt12 = (rsecp*v1m)**2
22279         opt14 = (v1m*v2m*rsecp)**2
22280         opt15 = -wquad1/v2m**2
22281         opt16 = (rthrp*(v1m*v2m)**2)**2
22282         opt17 = (v1m**2*rthrp)**2
22283         opt18 = -wquad1/rthrp
22284         opt19 = (v1m**2*v2m**2)**2
22285         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22286         do k=1,3
22287           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22288                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22289          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22290                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22291           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22292                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22293                       *v1dpv2)/opt14
22294         enddo
22295         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22296         do k=1,3
22297           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22298                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22299                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22300           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22301                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22302                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22303           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22304                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22305                         v1dpv2**2)/opt19
22306         enddo
22307         Equad2=wquad1*wquad2p*Irthrp
22308         do k=1,3
22309           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22310           dEquad2Cm(k)=3*dx(k)*rs*opt3
22311           dEquad2Calp(k)=0.0d0
22312         enddo
22313         Evan1=opt4*Irtw
22314         do k=1,3
22315           dEvan1Cat(k)=-dx(k)*opt5
22316           dEvan1Cm(k)=dx(k)*opt5
22317           dEvan1Calp(k)=0.0d0
22318         enddo
22319         Evan2=-opt6*Irsixp
22320         do k=1,3
22321           dEvan2Cat(k)=dx(k)*opt7
22322           dEvan2Cm(k)=-dx(k)*opt7
22323           dEvan2Calp(k)=0.0d0
22324         enddo
22325          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22326         do k=1,3
22327           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22328                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22329           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22330                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22331           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22332                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22333         enddo
22334             dscmag = 0.0d0
22335             do k=1,3
22336               dscvec(k) = c(k,i+nres)-c(k,i)
22337               dscmag = dscmag+dscvec(k)*dscvec(k)
22338             enddo
22339             dscmag3 = dscmag
22340             dscmag = sqrt(dscmag)
22341             dscmag3 = dscmag3*dscmag
22342             constA = 1+dASGL/dscmag
22343             constB = 0.0d0
22344             do k=1,3
22345               constB = constB+dscvec(k)*dEtotalCm(k)
22346             enddo
22347             constB = constB*dASGL/dscmag3
22348             do k=1,3
22349               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22350               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22351                constA*dEtotalCm(k)-constB*dscvec(k)
22352               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22353               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22354              enddo
22355            else
22356             rcal = 0.0d0
22357             do k=1,3
22358               r(k) = c(k,j)-c(k,i+nres)
22359               rcal = rcal+r(k)*r(k)
22360             enddo
22361             ract=sqrt(rcal)
22362             rocal=1.5
22363             epscalc=0.2
22364             r0p=0.5*(rocal+sig0(itype(i,1)))
22365             r06 = r0p**6
22366             r012 = r06*r06
22367             Evan1=epscalc*(r012/rcal**6)
22368             Evan2=epscalc*2*(r06/rcal**3)
22369             r4 = rcal**4
22370             r7 = rcal**7
22371             do k=1,3
22372               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22373               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22374             enddo
22375             do k=1,3
22376               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22377             enddo
22378                  ecation_prot = ecation_prot+ Evan1+Evan2
22379             do  k=1,3
22380                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22381                dEtotalCm(k)
22382               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22383               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22384              enddo
22385          endif ! 13-16 residues
22386        enddo !j
22387        enddo !i
22388        return
22389        end subroutine ecat_prot
22390
22391 !----------------------------------------------------------------------------
22392 !-----------------------------------------------------------------------------
22393 !-----------------------------------------------------------------------------
22394       subroutine eprot_sc_base(escbase)
22395       use calc_data
22396 !      implicit real*8 (a-h,o-z)
22397 !      include 'DIMENSIONS'
22398 !      include 'COMMON.GEO'
22399 !      include 'COMMON.VAR'
22400 !      include 'COMMON.LOCAL'
22401 !      include 'COMMON.CHAIN'
22402 !      include 'COMMON.DERIV'
22403 !      include 'COMMON.NAMES'
22404 !      include 'COMMON.INTERACT'
22405 !      include 'COMMON.IOUNITS'
22406 !      include 'COMMON.CALC'
22407 !      include 'COMMON.CONTROL'
22408 !      include 'COMMON.SBRIDGE'
22409       logical :: lprn
22410 !el local variables
22411       integer :: iint,itypi,itypi1,itypj,subchap
22412       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22413       real(kind=8) :: evdw,sig0ij
22414       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22415                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22416                     sslipi,sslipj,faclip
22417       integer :: ii
22418       real(kind=8) :: fracinbuf
22419        real (kind=8) :: escbase
22420        real (kind=8),dimension(4):: ener
22421        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22422        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22423         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22424         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22425         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22426         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22427         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22428         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22429        real(kind=8),dimension(3,2)::chead,erhead_tail
22430        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22431        integer troll
22432        eps_out=80.0d0
22433        escbase=0.0d0
22434 !       do i=1,nres_molec(1)
22435         do i=ibond_start,ibond_end
22436         if (itype(i,1).eq.ntyp1_molec(1)) cycle
22437         itypi  = itype(i,1)
22438         dxi    = dc_norm(1,nres+i)
22439         dyi    = dc_norm(2,nres+i)
22440         dzi    = dc_norm(3,nres+i)
22441         dsci_inv = vbld_inv(i+nres)
22442         xi=c(1,nres+i)
22443         yi=c(2,nres+i)
22444         zi=c(3,nres+i)
22445         xi=mod(xi,boxxsize)
22446          if (xi.lt.0) xi=xi+boxxsize
22447         yi=mod(yi,boxysize)
22448          if (yi.lt.0) yi=yi+boxysize
22449         zi=mod(zi,boxzsize)
22450          if (zi.lt.0) zi=zi+boxzsize
22451          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22452            itypj= itype(j,2)
22453            if (itype(j,2).eq.ntyp1_molec(2))cycle
22454            xj=c(1,j+nres)
22455            yj=c(2,j+nres)
22456            zj=c(3,j+nres)
22457            xj=dmod(xj,boxxsize)
22458            if (xj.lt.0) xj=xj+boxxsize
22459            yj=dmod(yj,boxysize)
22460            if (yj.lt.0) yj=yj+boxysize
22461            zj=dmod(zj,boxzsize)
22462            if (zj.lt.0) zj=zj+boxzsize
22463           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22464           xj_safe=xj
22465           yj_safe=yj
22466           zj_safe=zj
22467           subchap=0
22468
22469           do xshift=-1,1
22470           do yshift=-1,1
22471           do zshift=-1,1
22472           xj=xj_safe+xshift*boxxsize
22473           yj=yj_safe+yshift*boxysize
22474           zj=zj_safe+zshift*boxzsize
22475           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22476           if(dist_temp.lt.dist_init) then
22477             dist_init=dist_temp
22478             xj_temp=xj
22479             yj_temp=yj
22480             zj_temp=zj
22481             subchap=1
22482           endif
22483           enddo
22484           enddo
22485           enddo
22486           if (subchap.eq.1) then
22487           xj=xj_temp-xi
22488           yj=yj_temp-yi
22489           zj=zj_temp-zi
22490           else
22491           xj=xj_safe-xi
22492           yj=yj_safe-yi
22493           zj=zj_safe-zi
22494           endif
22495           dxj = dc_norm( 1, nres+j )
22496           dyj = dc_norm( 2, nres+j )
22497           dzj = dc_norm( 3, nres+j )
22498 !          print *,i,j,itypi,itypj
22499           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
22500           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
22501 !          d1i=0.0d0
22502 !          d1j=0.0d0
22503 !          BetaT = 1.0d0 / (298.0d0 * Rb)
22504 ! Gay-berne var's
22505           sig0ij = sigma_scbase( itypi,itypj )
22506           chi1   = chi_scbase( itypi, itypj,1 )
22507           chi2   = chi_scbase( itypi, itypj,2 )
22508 !          chi1=0.0d0
22509 !          chi2=0.0d0
22510           chi12  = chi1 * chi2
22511           chip1  = chipp_scbase( itypi, itypj,1 )
22512           chip2  = chipp_scbase( itypi, itypj,2 )
22513 !          chip1=0.0d0
22514 !          chip2=0.0d0
22515           chip12 = chip1 * chip2
22516 ! not used by momo potential, but needed by sc_angular which is shared
22517 ! by all energy_potential subroutines
22518           alf1   = 0.0d0
22519           alf2   = 0.0d0
22520           alf12  = 0.0d0
22521           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
22522 !       a12sq = a12sq * a12sq
22523 ! charge of amino acid itypi is...
22524           chis1 = chis_scbase(itypi,itypj,1)
22525           chis2 = chis_scbase(itypi,itypj,2)
22526           chis12 = chis1 * chis2
22527           sig1 = sigmap1_scbase(itypi,itypj)
22528           sig2 = sigmap2_scbase(itypi,itypj)
22529 !       write (*,*) "sig1 = ", sig1
22530 !       write (*,*) "sig2 = ", sig2
22531 ! alpha factors from Fcav/Gcav
22532           b1 = alphasur_scbase(1,itypi,itypj)
22533 !          b1=0.0d0
22534           b2 = alphasur_scbase(2,itypi,itypj)
22535           b3 = alphasur_scbase(3,itypi,itypj)
22536           b4 = alphasur_scbase(4,itypi,itypj)
22537 ! used to determine whether we want to do quadrupole calculations
22538 ! used by Fgb
22539        eps_in = epsintab_scbase(itypi,itypj)
22540        if (eps_in.eq.0.0) eps_in=1.0
22541        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22542 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
22543 !-------------------------------------------------------------------
22544 ! tail location and distance calculations
22545        DO k = 1,3
22546 ! location of polar head is computed by taking hydrophobic centre
22547 ! and moving by a d1 * dc_norm vector
22548 ! see unres publications for very informative images
22549         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
22550         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
22551 ! distance
22552 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22553 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22554         Rhead_distance(k) = chead(k,2) - chead(k,1)
22555        END DO
22556 ! pitagoras (root of sum of squares)
22557        Rhead = dsqrt( &
22558           (Rhead_distance(1)*Rhead_distance(1)) &
22559         + (Rhead_distance(2)*Rhead_distance(2)) &
22560         + (Rhead_distance(3)*Rhead_distance(3)))
22561 !-------------------------------------------------------------------
22562 ! zero everything that should be zero'ed
22563        evdwij = 0.0d0
22564        ECL = 0.0d0
22565        Elj = 0.0d0
22566        Equad = 0.0d0
22567        Epol = 0.0d0
22568        Fcav=0.0d0
22569        eheadtail = 0.0d0
22570        dGCLdOM1 = 0.0d0
22571        dGCLdOM2 = 0.0d0
22572        dGCLdOM12 = 0.0d0
22573        dPOLdOM1 = 0.0d0
22574        dPOLdOM2 = 0.0d0
22575           Fcav = 0.0d0
22576           dFdR = 0.0d0
22577           dCAVdOM1  = 0.0d0
22578           dCAVdOM2  = 0.0d0
22579           dCAVdOM12 = 0.0d0
22580           dscj_inv = vbld_inv(j+nres)
22581 !          print *,i,j,dscj_inv,dsci_inv
22582 ! rij holds 1/(distance of Calpha atoms)
22583           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22584           rij  = dsqrt(rrij)
22585 !----------------------------
22586           CALL sc_angular
22587 ! this should be in elgrad_init but om's are calculated by sc_angular
22588 ! which in turn is used by older potentials
22589 ! om = omega, sqom = om^2
22590           sqom1  = om1 * om1
22591           sqom2  = om2 * om2
22592           sqom12 = om12 * om12
22593
22594 ! now we calculate EGB - Gey-Berne
22595 ! It will be summed up in evdwij and saved in evdw
22596           sigsq     = 1.0D0  / sigsq
22597           sig       = sig0ij * dsqrt(sigsq)
22598 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22599           rij_shift = 1.0/rij - sig + sig0ij
22600           IF (rij_shift.le.0.0D0) THEN
22601            evdw = 1.0D20
22602            RETURN
22603           END IF
22604           sigder = -sig * sigsq
22605           rij_shift = 1.0D0 / rij_shift
22606           fac       = rij_shift**expon
22607           c1        = fac  * fac * aa_scbase(itypi,itypj)
22608 !          c1        = 0.0d0
22609           c2        = fac  * bb_scbase(itypi,itypj)
22610 !          c2        = 0.0d0
22611           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22612           eps2der   = eps3rt * evdwij
22613           eps3der   = eps2rt * evdwij
22614 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22615           evdwij    = eps2rt * eps3rt * evdwij
22616           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22617           fac    = -expon * (c1 + evdwij) * rij_shift
22618           sigder = fac * sigder
22619 !          fac    = rij * fac
22620 ! Calculate distance derivative
22621           gg(1) =  fac
22622           gg(2) =  fac
22623           gg(3) =  fac
22624 !          if (b2.gt.0.0) then
22625           fac = chis1 * sqom1 + chis2 * sqom2 &
22626           - 2.0d0 * chis12 * om1 * om2 * om12
22627 ! we will use pom later in Gcav, so dont mess with it!
22628           pom = 1.0d0 - chis1 * chis2 * sqom12
22629           Lambf = (1.0d0 - (fac / pom))
22630           Lambf = dsqrt(Lambf)
22631           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22632 !       write (*,*) "sparrow = ", sparrow
22633           Chif = 1.0d0/rij * sparrow
22634           ChiLambf = Chif * Lambf
22635           eagle = dsqrt(ChiLambf)
22636           bat = ChiLambf ** 11.0d0
22637           top = b1 * ( eagle + b2 * ChiLambf - b3 )
22638           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
22639           botsq = bot * bot
22640           Fcav = top / bot
22641 !          print *,i,j,Fcav
22642           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
22643           dbot = 12.0d0 * b4 * bat * Lambf
22644           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22645 !       dFdR = 0.0d0
22646 !      write (*,*) "dFcav/dR = ", dFdR
22647           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
22648           dbot = 12.0d0 * b4 * bat * Chif
22649           eagle = Lambf * pom
22650           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22651           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22652           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22653               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22654
22655           dFdL = ((dtop * bot - top * dbot) / botsq)
22656 !       dFdL = 0.0d0
22657           dCAVdOM1  = dFdL * ( dFdOM1 )
22658           dCAVdOM2  = dFdL * ( dFdOM2 )
22659           dCAVdOM12 = dFdL * ( dFdOM12 )
22660
22661           ertail(1) = xj*rij
22662           ertail(2) = yj*rij
22663           ertail(3) = zj*rij
22664 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
22665 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
22666 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
22667 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
22668 !           print *,"EOMY",eom1,eom2,eom12
22669 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22670 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
22671 ! here dtail=0.0
22672 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
22673 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22674        DO k = 1, 3
22675 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22676 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22677         pom = ertail(k)
22678 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22679         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22680                   - (( dFdR + gg(k) ) * pom)
22681 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22682 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22683 !     &             - ( dFdR * pom )
22684         pom = ertail(k)
22685 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22686         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22687                   + (( dFdR + gg(k) ) * pom)
22688 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22689 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22690 !c!     &             + ( dFdR * pom )
22691
22692         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22693                   - (( dFdR + gg(k) ) * ertail(k))
22694 !c!     &             - ( dFdR * ertail(k))
22695
22696         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22697                   + (( dFdR + gg(k) ) * ertail(k))
22698 !c!     &             + ( dFdR * ertail(k))
22699
22700         gg(k) = 0.0d0
22701 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22702 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22703       END DO
22704
22705 !          else
22706
22707 !          endif
22708 !Now dipole-dipole
22709          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
22710        w1 = wdipdip_scbase(1,itypi,itypj)
22711        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
22712        w3 = wdipdip_scbase(2,itypi,itypj)
22713 !c!-------------------------------------------------------------------
22714 !c! ECL
22715        fac = (om12 - 3.0d0 * om1 * om2)
22716        c1 = (w1 / (Rhead**3.0d0)) * fac
22717        c2 = (w2 / Rhead ** 6.0d0)  &
22718          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22719        c3= (w3/ Rhead ** 6.0d0)  &
22720          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22721        ECL = c1 - c2 + c3
22722 !c!       write (*,*) "w1 = ", w1
22723 !c!       write (*,*) "w2 = ", w2
22724 !c!       write (*,*) "om1 = ", om1
22725 !c!       write (*,*) "om2 = ", om2
22726 !c!       write (*,*) "om12 = ", om12
22727 !c!       write (*,*) "fac = ", fac
22728 !c!       write (*,*) "c1 = ", c1
22729 !c!       write (*,*) "c2 = ", c2
22730 !c!       write (*,*) "Ecl = ", Ecl
22731 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
22732 !c!       write (*,*) "c2_2 = ",
22733 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22734 !c!-------------------------------------------------------------------
22735 !c! dervative of ECL is GCL...
22736 !c! dECL/dr
22737        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
22738        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
22739          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
22740        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
22741          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22742        dGCLdR = c1 - c2 + c3
22743 !c! dECL/dom1
22744        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
22745        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22746          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
22747        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
22748        dGCLdOM1 = c1 - c2 + c3
22749 !c! dECL/dom2
22750        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
22751        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22752          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
22753        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
22754        dGCLdOM2 = c1 - c2 + c3
22755 !c! dECL/dom12
22756        c1 = w1 / (Rhead ** 3.0d0)
22757        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
22758        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
22759        dGCLdOM12 = c1 - c2 + c3
22760        DO k= 1, 3
22761         erhead(k) = Rhead_distance(k)/Rhead
22762        END DO
22763        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22764        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22765        facd1 = d1i * vbld_inv(i+nres)
22766        facd2 = d1j * vbld_inv(j+nres)
22767        DO k = 1, 3
22768
22769         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22770         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22771                   - dGCLdR * pom
22772         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22773         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22774                   + dGCLdR * pom
22775
22776         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22777                   - dGCLdR * erhead(k)
22778         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22779                   + dGCLdR * erhead(k)
22780        END DO
22781        endif
22782 !now charge with dipole eg. ARG-dG
22783        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
22784       alphapol1 = alphapol_scbase(itypi,itypj)
22785        w1        = wqdip_scbase(1,itypi,itypj)
22786        w2        = wqdip_scbase(2,itypi,itypj)
22787 !       w1=0.0d0
22788 !       w2=0.0d0
22789 !       pis       = sig0head_scbase(itypi,itypj)
22790 !       eps_head   = epshead_scbase(itypi,itypj)
22791 !c!-------------------------------------------------------------------
22792 !c! R1 - distance between head of ith side chain and tail of jth sidechain
22793        R1 = 0.0d0
22794        DO k = 1, 3
22795 !c! Calculate head-to-tail distances tail is center of side-chain
22796         R1=R1+(c(k,j+nres)-chead(k,1))**2
22797        END DO
22798 !c! Pitagoras
22799        R1 = dsqrt(R1)
22800
22801 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
22802 !c!     &        +dhead(1,1,itypi,itypj))**2))
22803 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
22804 !c!     &        +dhead(2,1,itypi,itypj))**2))
22805
22806 !c!-------------------------------------------------------------------
22807 !c! ecl
22808        sparrow  = w1  *  om1
22809        hawk     = w2 *  (1.0d0 - sqom2)
22810        Ecl = sparrow / Rhead**2.0d0 &
22811            - hawk    / Rhead**4.0d0
22812 !c!-------------------------------------------------------------------
22813 !c! derivative of ecl is Gcl
22814 !c! dF/dr part
22815        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
22816                 + 4.0d0 * hawk    / Rhead**5.0d0
22817 !c! dF/dom1
22818        dGCLdOM1 = (w1) / (Rhead**2.0d0)
22819 !c! dF/dom2
22820        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
22821 !c--------------------------------------------------------------------
22822 !c Polarization energy
22823 !c Epol
22824        MomoFac1 = (1.0d0 - chi1 * sqom2)
22825        RR1  = R1 * R1 / MomoFac1
22826        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
22827        fgb1 = sqrt( RR1 + a12sq * ee1)
22828 !       eps_inout_fac=0.0d0
22829        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
22830 ! derivative of Epol is Gpol...
22831        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
22832                 / (fgb1 ** 5.0d0)
22833        dFGBdR1 = ( (R1 / MomoFac1) &
22834              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
22835              / ( 2.0d0 * fgb1 )
22836        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
22837                * (2.0d0 - 0.5d0 * ee1) ) &
22838                / (2.0d0 * fgb1)
22839        dPOLdR1 = dPOLdFGB1 * dFGBdR1
22840 !       dPOLdR1 = 0.0d0
22841        dPOLdOM1 = 0.0d0
22842        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
22843        DO k = 1, 3
22844         erhead(k) = Rhead_distance(k)/Rhead
22845         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
22846        END DO
22847
22848        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22849        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22850        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
22851 !       bat=0.0d0
22852        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
22853        facd1 = d1i * vbld_inv(i+nres)
22854        facd2 = d1j * vbld_inv(j+nres)
22855 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22856
22857        DO k = 1, 3
22858         hawk = (erhead_tail(k,1) + &
22859         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
22860 !        facd1=0.0d0
22861 !        facd2=0.0d0
22862         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22863         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
22864                    - dGCLdR * pom &
22865                    - dPOLdR1 *  (erhead_tail(k,1))
22866 !     &             - dGLJdR * pom
22867
22868         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22869         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
22870                    + dGCLdR * pom  &
22871                    + dPOLdR1 * (erhead_tail(k,1))
22872 !     &             + dGLJdR * pom
22873
22874
22875         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
22876                   - dGCLdR * erhead(k) &
22877                   - dPOLdR1 * erhead_tail(k,1)
22878 !     &             - dGLJdR * erhead(k)
22879
22880         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
22881                   + dGCLdR * erhead(k)  &
22882                   + dPOLdR1 * erhead_tail(k,1)
22883 !     &             + dGLJdR * erhead(k)
22884
22885        END DO
22886        endif
22887 !       print *,i,j,evdwij,epol,Fcav,ECL
22888        escbase=escbase+evdwij+epol+Fcav+ECL
22889        call sc_grad_scbase
22890          enddo
22891       enddo
22892
22893       return
22894       end subroutine eprot_sc_base
22895       SUBROUTINE sc_grad_scbase
22896       use calc_data
22897
22898        real (kind=8) :: dcosom1(3),dcosom2(3)
22899        eom1  =    &
22900               eps2der * eps2rt_om1   &
22901             - 2.0D0 * alf1 * eps3der &
22902             + sigder * sigsq_om1     &
22903             + dCAVdOM1               &
22904             + dGCLdOM1               &
22905             + dPOLdOM1
22906
22907        eom2  =  &
22908               eps2der * eps2rt_om2   &
22909             + 2.0D0 * alf2 * eps3der &
22910             + sigder * sigsq_om2     &
22911             + dCAVdOM2               &
22912             + dGCLdOM2               &
22913             + dPOLdOM2
22914
22915        eom12 =    &
22916               evdwij  * eps1_om12     &
22917             + eps2der * eps2rt_om12   &
22918             - 2.0D0 * alf12 * eps3der &
22919             + sigder *sigsq_om12      &
22920             + dCAVdOM12               &
22921             + dGCLdOM12
22922
22923 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
22924 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
22925 !               gg(1),gg(2),"rozne"
22926        DO k = 1, 3
22927         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
22928         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
22929         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
22930         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
22931                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22932                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22933         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
22934                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22935                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22936         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
22937         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
22938        END DO
22939        RETURN
22940       END SUBROUTINE sc_grad_scbase
22941
22942
22943       subroutine epep_sc_base(epepbase)
22944       use calc_data
22945       logical :: lprn
22946 !el local variables
22947       integer :: iint,itypi,itypi1,itypj,subchap
22948       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22949       real(kind=8) :: evdw,sig0ij
22950       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22951                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22952                     sslipi,sslipj,faclip
22953       integer :: ii
22954       real(kind=8) :: fracinbuf
22955        real (kind=8) :: epepbase
22956        real (kind=8),dimension(4):: ener
22957        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22958        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22959         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22960         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22961         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22962         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22963         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22964         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22965        real(kind=8),dimension(3,2)::chead,erhead_tail
22966        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22967        integer troll
22968        eps_out=80.0d0
22969        epepbase=0.0d0
22970 !       do i=1,nres_molec(1)-1
22971         do i=ibond_start,ibond_end
22972         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
22973 !C        itypi  = itype(i,1)
22974         dxi    = dc_norm(1,i)
22975         dyi    = dc_norm(2,i)
22976         dzi    = dc_norm(3,i)
22977 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
22978         dsci_inv = vbld_inv(i+1)/2.0
22979         xi=(c(1,i)+c(1,i+1))/2.0
22980         yi=(c(2,i)+c(2,i+1))/2.0
22981         zi=(c(3,i)+c(3,i+1))/2.0
22982         xi=mod(xi,boxxsize)
22983          if (xi.lt.0) xi=xi+boxxsize
22984         yi=mod(yi,boxysize)
22985          if (yi.lt.0) yi=yi+boxysize
22986         zi=mod(zi,boxzsize)
22987          if (zi.lt.0) zi=zi+boxzsize
22988          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22989            itypj= itype(j,2)
22990            if (itype(j,2).eq.ntyp1_molec(2))cycle
22991            xj=c(1,j+nres)
22992            yj=c(2,j+nres)
22993            zj=c(3,j+nres)
22994            xj=dmod(xj,boxxsize)
22995            if (xj.lt.0) xj=xj+boxxsize
22996            yj=dmod(yj,boxysize)
22997            if (yj.lt.0) yj=yj+boxysize
22998            zj=dmod(zj,boxzsize)
22999            if (zj.lt.0) zj=zj+boxzsize
23000           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23001           xj_safe=xj
23002           yj_safe=yj
23003           zj_safe=zj
23004           subchap=0
23005
23006           do xshift=-1,1
23007           do yshift=-1,1
23008           do zshift=-1,1
23009           xj=xj_safe+xshift*boxxsize
23010           yj=yj_safe+yshift*boxysize
23011           zj=zj_safe+zshift*boxzsize
23012           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23013           if(dist_temp.lt.dist_init) then
23014             dist_init=dist_temp
23015             xj_temp=xj
23016             yj_temp=yj
23017             zj_temp=zj
23018             subchap=1
23019           endif
23020           enddo
23021           enddo
23022           enddo
23023           if (subchap.eq.1) then
23024           xj=xj_temp-xi
23025           yj=yj_temp-yi
23026           zj=zj_temp-zi
23027           else
23028           xj=xj_safe-xi
23029           yj=yj_safe-yi
23030           zj=zj_safe-zi
23031           endif
23032           dxj = dc_norm( 1, nres+j )
23033           dyj = dc_norm( 2, nres+j )
23034           dzj = dc_norm( 3, nres+j )
23035 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23036 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23037
23038 ! Gay-berne var's
23039           sig0ij = sigma_pepbase(itypj )
23040           chi1   = chi_pepbase(itypj,1 )
23041           chi2   = chi_pepbase(itypj,2 )
23042 !          chi1=0.0d0
23043 !          chi2=0.0d0
23044           chi12  = chi1 * chi2
23045           chip1  = chipp_pepbase(itypj,1 )
23046           chip2  = chipp_pepbase(itypj,2 )
23047 !          chip1=0.0d0
23048 !          chip2=0.0d0
23049           chip12 = chip1 * chip2
23050           chis1 = chis_pepbase(itypj,1)
23051           chis2 = chis_pepbase(itypj,2)
23052           chis12 = chis1 * chis2
23053           sig1 = sigmap1_pepbase(itypj)
23054           sig2 = sigmap2_pepbase(itypj)
23055 !       write (*,*) "sig1 = ", sig1
23056 !       write (*,*) "sig2 = ", sig2
23057        DO k = 1,3
23058 ! location of polar head is computed by taking hydrophobic centre
23059 ! and moving by a d1 * dc_norm vector
23060 ! see unres publications for very informative images
23061         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23062 ! + d1i * dc_norm(k, i+nres)
23063         chead(k,2) = c(k, j+nres)
23064 ! + d1j * dc_norm(k, j+nres)
23065 ! distance
23066 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23067 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23068         Rhead_distance(k) = chead(k,2) - chead(k,1)
23069 !        print *,gvdwc_pepbase(k,i)
23070
23071        END DO
23072        Rhead = dsqrt( &
23073           (Rhead_distance(1)*Rhead_distance(1)) &
23074         + (Rhead_distance(2)*Rhead_distance(2)) &
23075         + (Rhead_distance(3)*Rhead_distance(3)))
23076
23077 ! alpha factors from Fcav/Gcav
23078           b1 = alphasur_pepbase(1,itypj)
23079 !          b1=0.0d0
23080           b2 = alphasur_pepbase(2,itypj)
23081           b3 = alphasur_pepbase(3,itypj)
23082           b4 = alphasur_pepbase(4,itypj)
23083           alf1   = 0.0d0
23084           alf2   = 0.0d0
23085           alf12  = 0.0d0
23086           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23087 !          print *,i,j,rrij
23088           rij  = dsqrt(rrij)
23089 !----------------------------
23090        evdwij = 0.0d0
23091        ECL = 0.0d0
23092        Elj = 0.0d0
23093        Equad = 0.0d0
23094        Epol = 0.0d0
23095        Fcav=0.0d0
23096        eheadtail = 0.0d0
23097        dGCLdOM1 = 0.0d0
23098        dGCLdOM2 = 0.0d0
23099        dGCLdOM12 = 0.0d0
23100        dPOLdOM1 = 0.0d0
23101        dPOLdOM2 = 0.0d0
23102           Fcav = 0.0d0
23103           dFdR = 0.0d0
23104           dCAVdOM1  = 0.0d0
23105           dCAVdOM2  = 0.0d0
23106           dCAVdOM12 = 0.0d0
23107           dscj_inv = vbld_inv(j+nres)
23108           CALL sc_angular
23109 ! this should be in elgrad_init but om's are calculated by sc_angular
23110 ! which in turn is used by older potentials
23111 ! om = omega, sqom = om^2
23112           sqom1  = om1 * om1
23113           sqom2  = om2 * om2
23114           sqom12 = om12 * om12
23115
23116 ! now we calculate EGB - Gey-Berne
23117 ! It will be summed up in evdwij and saved in evdw
23118           sigsq     = 1.0D0  / sigsq
23119           sig       = sig0ij * dsqrt(sigsq)
23120           rij_shift = 1.0/rij - sig + sig0ij
23121           IF (rij_shift.le.0.0D0) THEN
23122            evdw = 1.0D20
23123            RETURN
23124           END IF
23125           sigder = -sig * sigsq
23126           rij_shift = 1.0D0 / rij_shift
23127           fac       = rij_shift**expon
23128           c1        = fac  * fac * aa_pepbase(itypj)
23129 !          c1        = 0.0d0
23130           c2        = fac  * bb_pepbase(itypj)
23131 !          c2        = 0.0d0
23132           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23133           eps2der   = eps3rt * evdwij
23134           eps3der   = eps2rt * evdwij
23135 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23136           evdwij    = eps2rt * eps3rt * evdwij
23137           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23138           fac    = -expon * (c1 + evdwij) * rij_shift
23139           sigder = fac * sigder
23140 !          fac    = rij * fac
23141 ! Calculate distance derivative
23142           gg(1) =  fac
23143           gg(2) =  fac
23144           gg(3) =  fac
23145           fac = chis1 * sqom1 + chis2 * sqom2 &
23146           - 2.0d0 * chis12 * om1 * om2 * om12
23147 ! we will use pom later in Gcav, so dont mess with it!
23148           pom = 1.0d0 - chis1 * chis2 * sqom12
23149           Lambf = (1.0d0 - (fac / pom))
23150           Lambf = dsqrt(Lambf)
23151           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23152 !       write (*,*) "sparrow = ", sparrow
23153           Chif = 1.0d0/rij * sparrow
23154           ChiLambf = Chif * Lambf
23155           eagle = dsqrt(ChiLambf)
23156           bat = ChiLambf ** 11.0d0
23157           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23158           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23159           botsq = bot * bot
23160           Fcav = top / bot
23161 !          print *,i,j,Fcav
23162           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23163           dbot = 12.0d0 * b4 * bat * Lambf
23164           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23165 !       dFdR = 0.0d0
23166 !      write (*,*) "dFcav/dR = ", dFdR
23167           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23168           dbot = 12.0d0 * b4 * bat * Chif
23169           eagle = Lambf * pom
23170           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23171           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23172           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23173               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23174
23175           dFdL = ((dtop * bot - top * dbot) / botsq)
23176 !       dFdL = 0.0d0
23177           dCAVdOM1  = dFdL * ( dFdOM1 )
23178           dCAVdOM2  = dFdL * ( dFdOM2 )
23179           dCAVdOM12 = dFdL * ( dFdOM12 )
23180
23181           ertail(1) = xj*rij
23182           ertail(2) = yj*rij
23183           ertail(3) = zj*rij
23184        DO k = 1, 3
23185 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23186 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23187         pom = ertail(k)
23188 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23189         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23190                   - (( dFdR + gg(k) ) * pom)/2.0
23191 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
23192 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23193 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23194 !     &             - ( dFdR * pom )
23195         pom = ertail(k)
23196 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23197         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23198                   + (( dFdR + gg(k) ) * pom)
23199 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23200 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23201 !c!     &             + ( dFdR * pom )
23202
23203         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23204                   - (( dFdR + gg(k) ) * ertail(k))/2.0
23205 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
23206
23207 !c!     &             - ( dFdR * ertail(k))
23208
23209         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23210                   + (( dFdR + gg(k) ) * ertail(k))
23211 !c!     &             + ( dFdR * ertail(k))
23212
23213         gg(k) = 0.0d0
23214 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23215 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23216       END DO
23217
23218
23219        w1 = wdipdip_pepbase(1,itypj)
23220        w2 = -wdipdip_pepbase(3,itypj)/2.0
23221        w3 = wdipdip_pepbase(2,itypj)
23222 !       w1=0.0d0
23223 !       w2=0.0d0
23224 !c!-------------------------------------------------------------------
23225 !c! ECL
23226 !       w3=0.0d0
23227        fac = (om12 - 3.0d0 * om1 * om2)
23228        c1 = (w1 / (Rhead**3.0d0)) * fac
23229        c2 = (w2 / Rhead ** 6.0d0)  &
23230          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23231        c3= (w3/ Rhead ** 6.0d0)  &
23232          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23233
23234        ECL = c1 - c2 + c3
23235
23236        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23237        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23238          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23239        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23240          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23241
23242        dGCLdR = c1 - c2 + c3
23243 !c! dECL/dom1
23244        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23245        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23246          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23247        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23248        dGCLdOM1 = c1 - c2 + c3
23249 !c! dECL/dom2
23250        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23251        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23252          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23253        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23254
23255        dGCLdOM2 = c1 - c2 + c3
23256 !c! dECL/dom12
23257        c1 = w1 / (Rhead ** 3.0d0)
23258        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23259        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23260        dGCLdOM12 = c1 - c2 + c3
23261        DO k= 1, 3
23262         erhead(k) = Rhead_distance(k)/Rhead
23263        END DO
23264        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23265        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23266 !       facd1 = d1 * vbld_inv(i+nres)
23267 !       facd2 = d2 * vbld_inv(j+nres)
23268        DO k = 1, 3
23269
23270 !        pom = erhead(k)
23271 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23272 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
23273 !                  - dGCLdR * pom
23274         pom = erhead(k)
23275 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23276         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23277                   + dGCLdR * pom
23278
23279         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23280                   - dGCLdR * erhead(k)/2.0d0
23281 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23282         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23283                   - dGCLdR * erhead(k)/2.0d0
23284 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23285         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23286                   + dGCLdR * erhead(k)
23287        END DO
23288 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
23289        epepbase=epepbase+evdwij+Fcav+ECL
23290        call sc_grad_pepbase
23291        enddo
23292        enddo
23293       END SUBROUTINE epep_sc_base
23294       SUBROUTINE sc_grad_pepbase
23295       use calc_data
23296
23297        real (kind=8) :: dcosom1(3),dcosom2(3)
23298        eom1  =    &
23299               eps2der * eps2rt_om1   &
23300             - 2.0D0 * alf1 * eps3der &
23301             + sigder * sigsq_om1     &
23302             + dCAVdOM1               &
23303             + dGCLdOM1               &
23304             + dPOLdOM1
23305
23306        eom2  =  &
23307               eps2der * eps2rt_om2   &
23308             + 2.0D0 * alf2 * eps3der &
23309             + sigder * sigsq_om2     &
23310             + dCAVdOM2               &
23311             + dGCLdOM2               &
23312             + dPOLdOM2
23313
23314        eom12 =    &
23315               evdwij  * eps1_om12     &
23316             + eps2der * eps2rt_om12   &
23317             - 2.0D0 * alf12 * eps3der &
23318             + sigder *sigsq_om12      &
23319             + dCAVdOM12               &
23320             + dGCLdOM12
23321 !        om12=0.0
23322 !        eom12=0.0
23323 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23324 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
23325 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23326 !                 *dsci_inv*2.0
23327 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23328 !               gg(1),gg(2),"rozne"
23329        DO k = 1, 3
23330         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
23331         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23332         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23333         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
23334                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23335                  *dsci_inv*2.0 &
23336                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23337         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
23338                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
23339                  *dsci_inv*2.0 &
23340                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23341 !         print *,eom12,eom2,om12,om2
23342 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23343 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23344         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
23345                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23346                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23347         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
23348        END DO
23349        RETURN
23350       END SUBROUTINE sc_grad_pepbase
23351       subroutine eprot_sc_phosphate(escpho)
23352       use calc_data
23353 !      implicit real*8 (a-h,o-z)
23354 !      include 'DIMENSIONS'
23355 !      include 'COMMON.GEO'
23356 !      include 'COMMON.VAR'
23357 !      include 'COMMON.LOCAL'
23358 !      include 'COMMON.CHAIN'
23359 !      include 'COMMON.DERIV'
23360 !      include 'COMMON.NAMES'
23361 !      include 'COMMON.INTERACT'
23362 !      include 'COMMON.IOUNITS'
23363 !      include 'COMMON.CALC'
23364 !      include 'COMMON.CONTROL'
23365 !      include 'COMMON.SBRIDGE'
23366       logical :: lprn
23367 !el local variables
23368       integer :: iint,itypi,itypi1,itypj,subchap
23369       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23370       real(kind=8) :: evdw,sig0ij
23371       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23372                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23373                     sslipi,sslipj,faclip
23374       integer :: ii
23375       real(kind=8) :: fracinbuf
23376        real (kind=8) :: escpho
23377        real (kind=8),dimension(4):: ener
23378        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23379        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23380         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23381         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23382         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23383         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23384         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23385         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23386        real(kind=8),dimension(3,2)::chead,erhead_tail
23387        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23388        integer troll
23389        eps_out=80.0d0
23390        escpho=0.0d0
23391 !       do i=1,nres_molec(1)
23392         do i=ibond_start,ibond_end
23393         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23394         itypi  = itype(i,1)
23395         dxi    = dc_norm(1,nres+i)
23396         dyi    = dc_norm(2,nres+i)
23397         dzi    = dc_norm(3,nres+i)
23398         dsci_inv = vbld_inv(i+nres)
23399         xi=c(1,nres+i)
23400         yi=c(2,nres+i)
23401         zi=c(3,nres+i)
23402         xi=mod(xi,boxxsize)
23403          if (xi.lt.0) xi=xi+boxxsize
23404         yi=mod(yi,boxysize)
23405          if (yi.lt.0) yi=yi+boxysize
23406         zi=mod(zi,boxzsize)
23407          if (zi.lt.0) zi=zi+boxzsize
23408          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23409            itypj= itype(j,2)
23410            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23411             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23412            xj=(c(1,j)+c(1,j+1))/2.0
23413            yj=(c(2,j)+c(2,j+1))/2.0
23414            zj=(c(3,j)+c(3,j+1))/2.0
23415            xj=dmod(xj,boxxsize)
23416            if (xj.lt.0) xj=xj+boxxsize
23417            yj=dmod(yj,boxysize)
23418            if (yj.lt.0) yj=yj+boxysize
23419            zj=dmod(zj,boxzsize)
23420            if (zj.lt.0) zj=zj+boxzsize
23421           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23422           xj_safe=xj
23423           yj_safe=yj
23424           zj_safe=zj
23425           subchap=0
23426           do xshift=-1,1
23427           do yshift=-1,1
23428           do zshift=-1,1
23429           yj=yj_safe+yshift*boxysize
23430           zj=zj_safe+zshift*boxzsize
23431           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23432           if(dist_temp.lt.dist_init) then
23433             dist_init=dist_temp
23434             xj_temp=xj
23435             yj_temp=yj
23436             zj_temp=zj
23437             subchap=1
23438           endif
23439           enddo
23440           enddo
23441           enddo
23442           if (subchap.eq.1) then
23443           xj=xj_temp-xi
23444           yj=yj_temp-yi
23445           zj=zj_temp-zi
23446           else
23447           xj=xj_safe-xi
23448           yj=yj_safe-yi
23449           zj=zj_safe-zi
23450           endif
23451           dxj = dc_norm( 1,j )
23452           dyj = dc_norm( 2,j )
23453           dzj = dc_norm( 3,j )
23454           dscj_inv = vbld_inv(j+1)
23455
23456 ! Gay-berne var's
23457           sig0ij = sigma_scpho(itypi )
23458           chi1   = chi_scpho(itypi,1 )
23459           chi2   = chi_scpho(itypi,2 )
23460 !          chi1=0.0d0
23461 !          chi2=0.0d0
23462           chi12  = chi1 * chi2
23463           chip1  = chipp_scpho(itypi,1 )
23464           chip2  = chipp_scpho(itypi,2 )
23465 !          chip1=0.0d0
23466 !          chip2=0.0d0
23467           chip12 = chip1 * chip2
23468           chis1 = chis_scpho(itypi,1)
23469           chis2 = chis_scpho(itypi,2)
23470           chis12 = chis1 * chis2
23471           sig1 = sigmap1_scpho(itypi)
23472           sig2 = sigmap2_scpho(itypi)
23473 !       write (*,*) "sig1 = ", sig1
23474 !       write (*,*) "sig1 = ", sig1
23475 !       write (*,*) "sig2 = ", sig2
23476 ! alpha factors from Fcav/Gcav
23477           alf1   = 0.0d0
23478           alf2   = 0.0d0
23479           alf12  = 0.0d0
23480           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
23481
23482           b1 = alphasur_scpho(1,itypi)
23483 !          b1=0.0d0
23484           b2 = alphasur_scpho(2,itypi)
23485           b3 = alphasur_scpho(3,itypi)
23486           b4 = alphasur_scpho(4,itypi)
23487 ! used to determine whether we want to do quadrupole calculations
23488 ! used by Fgb
23489        eps_in = epsintab_scpho(itypi)
23490        if (eps_in.eq.0.0) eps_in=1.0
23491        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23492 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23493 !-------------------------------------------------------------------
23494 ! tail location and distance calculations
23495           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
23496           d1j = 0.0
23497        DO k = 1,3
23498 ! location of polar head is computed by taking hydrophobic centre
23499 ! and moving by a d1 * dc_norm vector
23500 ! see unres publications for very informative images
23501         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23502         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
23503 ! distance
23504 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23505 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23506         Rhead_distance(k) = chead(k,2) - chead(k,1)
23507        END DO
23508 ! pitagoras (root of sum of squares)
23509        Rhead = dsqrt( &
23510           (Rhead_distance(1)*Rhead_distance(1)) &
23511         + (Rhead_distance(2)*Rhead_distance(2)) &
23512         + (Rhead_distance(3)*Rhead_distance(3)))
23513        Rhead_sq=Rhead**2.0
23514 !-------------------------------------------------------------------
23515 ! zero everything that should be zero'ed
23516        evdwij = 0.0d0
23517        ECL = 0.0d0
23518        Elj = 0.0d0
23519        Equad = 0.0d0
23520        Epol = 0.0d0
23521        Fcav=0.0d0
23522        eheadtail = 0.0d0
23523        dGCLdR=0.0d0
23524        dGCLdOM1 = 0.0d0
23525        dGCLdOM2 = 0.0d0
23526        dGCLdOM12 = 0.0d0
23527        dPOLdOM1 = 0.0d0
23528        dPOLdOM2 = 0.0d0
23529           Fcav = 0.0d0
23530           dFdR = 0.0d0
23531           dCAVdOM1  = 0.0d0
23532           dCAVdOM2  = 0.0d0
23533           dCAVdOM12 = 0.0d0
23534           dscj_inv = vbld_inv(j+1)/2.0
23535 !dhead_scbasej(itypi,itypj)
23536 !          print *,i,j,dscj_inv,dsci_inv
23537 ! rij holds 1/(distance of Calpha atoms)
23538           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23539           rij  = dsqrt(rrij)
23540 !----------------------------
23541           CALL sc_angular
23542 ! this should be in elgrad_init but om's are calculated by sc_angular
23543 ! which in turn is used by older potentials
23544 ! om = omega, sqom = om^2
23545           sqom1  = om1 * om1
23546           sqom2  = om2 * om2
23547           sqom12 = om12 * om12
23548
23549 ! now we calculate EGB - Gey-Berne
23550 ! It will be summed up in evdwij and saved in evdw
23551           sigsq     = 1.0D0  / sigsq
23552           sig       = sig0ij * dsqrt(sigsq)
23553 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23554           rij_shift = 1.0/rij - sig + sig0ij
23555           IF (rij_shift.le.0.0D0) THEN
23556            evdw = 1.0D20
23557            RETURN
23558           END IF
23559           sigder = -sig * sigsq
23560           rij_shift = 1.0D0 / rij_shift
23561           fac       = rij_shift**expon
23562           c1        = fac  * fac * aa_scpho(itypi)
23563 !          c1        = 0.0d0
23564           c2        = fac  * bb_scpho(itypi)
23565 !          c2        = 0.0d0
23566           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23567           eps2der   = eps3rt * evdwij
23568           eps3der   = eps2rt * evdwij
23569 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23570           evdwij    = eps2rt * eps3rt * evdwij
23571           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23572           fac    = -expon * (c1 + evdwij) * rij_shift
23573           sigder = fac * sigder
23574 !          fac    = rij * fac
23575 ! Calculate distance derivative
23576           gg(1) =  fac
23577           gg(2) =  fac
23578           gg(3) =  fac
23579           fac = chis1 * sqom1 + chis2 * sqom2 &
23580           - 2.0d0 * chis12 * om1 * om2 * om12
23581 ! we will use pom later in Gcav, so dont mess with it!
23582           pom = 1.0d0 - chis1 * chis2 * sqom12
23583           Lambf = (1.0d0 - (fac / pom))
23584           Lambf = dsqrt(Lambf)
23585           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23586 !       write (*,*) "sparrow = ", sparrow
23587           Chif = 1.0d0/rij * sparrow
23588           ChiLambf = Chif * Lambf
23589           eagle = dsqrt(ChiLambf)
23590           bat = ChiLambf ** 11.0d0
23591           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23592           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23593           botsq = bot * bot
23594           Fcav = top / bot
23595           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23596           dbot = 12.0d0 * b4 * bat * Lambf
23597           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23598 !       dFdR = 0.0d0
23599 !      write (*,*) "dFcav/dR = ", dFdR
23600           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23601           dbot = 12.0d0 * b4 * bat * Chif
23602           eagle = Lambf * pom
23603           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23604           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23605           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23606               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23607
23608           dFdL = ((dtop * bot - top * dbot) / botsq)
23609 !       dFdL = 0.0d0
23610           dCAVdOM1  = dFdL * ( dFdOM1 )
23611           dCAVdOM2  = dFdL * ( dFdOM2 )
23612           dCAVdOM12 = dFdL * ( dFdOM12 )
23613
23614           ertail(1) = xj*rij
23615           ertail(2) = yj*rij
23616           ertail(3) = zj*rij
23617        DO k = 1, 3
23618 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23619 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23620 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
23621
23622         pom = ertail(k)
23623 !        print *,pom,gg(k),dFdR
23624 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23625         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
23626                   - (( dFdR + gg(k) ) * pom)
23627 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23628 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23629 !     &             - ( dFdR * pom )
23630 !        pom = ertail(k)
23631 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23632 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
23633 !                  + (( dFdR + gg(k) ) * pom)
23634 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23635 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23636 !c!     &             + ( dFdR * pom )
23637
23638         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
23639                   - (( dFdR + gg(k) ) * ertail(k))
23640 !c!     &             - ( dFdR * ertail(k))
23641
23642         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
23643                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23644
23645         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
23646                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23647
23648 !c!     &             + ( dFdR * ertail(k))
23649
23650         gg(k) = 0.0d0
23651         ENDDO
23652 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23653 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23654 !      alphapol1 = alphapol_scpho(itypi)
23655        if (wqq_scpho(itypi).gt.0.0) then
23656        Qij=wqq_scpho(itypi)/eps_in
23657 !       Qij=0.0
23658        Ecl = (332.0d0 * Qij) / Rhead
23659 !c! derivative of Ecl is Gcl...
23660        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
23661        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
23662        w1        = wqdip_scpho(1,itypi)
23663        w2        = wqdip_scpho(2,itypi)
23664 !       w1=0.0d0
23665 !       w2=0.0d0
23666 !       pis       = sig0head_scbase(itypi,itypj)
23667 !       eps_head   = epshead_scbase(itypi,itypj)
23668 !c!-------------------------------------------------------------------
23669
23670 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23671 !c!     &        +dhead(1,1,itypi,itypj))**2))
23672 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23673 !c!     &        +dhead(2,1,itypi,itypj))**2))
23674
23675 !c!-------------------------------------------------------------------
23676 !c! ecl
23677        sparrow  = w1  *  om1
23678        hawk     = w2 *  (1.0d0 - sqom2)
23679        Ecl = sparrow / Rhead**2.0d0 &
23680            - hawk    / Rhead**4.0d0
23681 !c!-------------------------------------------------------------------
23682 !c! derivative of ecl is Gcl
23683 !c! dF/dr part
23684        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23685                 + 4.0d0 * hawk    / Rhead**5.0d0
23686 !c! dF/dom1
23687        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23688 !c! dF/dom2
23689        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23690        endif
23691
23692 !c--------------------------------------------------------------------
23693 !c Polarization energy
23694 !c Epol
23695        R1 = 0.0d0
23696        DO k = 1, 3
23697 !c! Calculate head-to-tail distances tail is center of side-chain
23698         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
23699        END DO
23700 !c! Pitagoras
23701        R1 = dsqrt(R1)
23702
23703       alphapol1 = alphapol_scpho(itypi)
23704 !      alphapol1=0.0
23705        MomoFac1 = (1.0d0 - chi2 * sqom1)
23706        RR1  = R1 * R1 / MomoFac1
23707        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23708 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
23709        fgb1 = sqrt( RR1 + a12sq * ee1)
23710 !       eps_inout_fac=0.0d0
23711        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23712 ! derivative of Epol is Gpol...
23713        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23714                 / (fgb1 ** 5.0d0)
23715        dFGBdR1 = ( (R1 / MomoFac1) &
23716              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23717              / ( 2.0d0 * fgb1 )
23718        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23719                * (2.0d0 - 0.5d0 * ee1) ) &
23720                / (2.0d0 * fgb1)
23721        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23722 !       dPOLdR1 = 0.0d0
23723 !       dPOLdOM1 = 0.0d0
23724        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
23725                * (2.0d0 - 0.5d0 * ee1) ) &
23726                / (2.0d0 * fgb1)
23727
23728        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
23729        dPOLdOM2 = 0.0
23730        DO k = 1, 3
23731         erhead(k) = Rhead_distance(k)/Rhead
23732         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
23733        END DO
23734
23735        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23736        erdxj = scalar( erhead(1), dC_norm(1,j) )
23737        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23738 !       bat=0.0d0
23739        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
23740        facd1 = d1i * vbld_inv(i+nres)
23741        facd2 = d1j * vbld_inv(j)
23742 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23743
23744        DO k = 1, 3
23745         hawk = (erhead_tail(k,1) + &
23746         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23747 !        facd1=0.0d0
23748 !        facd2=0.0d0
23749 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
23750 !                pom,(erhead_tail(k,1))
23751
23752 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
23753         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23754         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
23755                    - dGCLdR * pom &
23756                    - dPOLdR1 *  (erhead_tail(k,1))
23757 !     &             - dGLJdR * pom
23758
23759         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
23760 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
23761 !                   + dGCLdR * pom  &
23762 !                   + dPOLdR1 * (erhead_tail(k,1))
23763 !     &             + dGLJdR * pom
23764
23765
23766         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
23767                   - dGCLdR * erhead(k) &
23768                   - dPOLdR1 * erhead_tail(k,1)
23769 !     &             - dGLJdR * erhead(k)
23770
23771         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
23772                   + (dGCLdR * erhead(k)  &
23773                   + dPOLdR1 * erhead_tail(k,1))/2.0
23774         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
23775                   + (dGCLdR * erhead(k)  &
23776                   + dPOLdR1 * erhead_tail(k,1))/2.0
23777
23778 !     &             + dGLJdR * erhead(k)
23779 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
23780
23781        END DO
23782 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
23783        escpho=escpho+evdwij+epol+Fcav+ECL
23784        call sc_grad_scpho
23785          enddo
23786
23787       enddo
23788
23789       return
23790       end subroutine eprot_sc_phosphate
23791       SUBROUTINE sc_grad_scpho
23792       use calc_data
23793
23794        real (kind=8) :: dcosom1(3),dcosom2(3)
23795        eom1  =    &
23796               eps2der * eps2rt_om1   &
23797             - 2.0D0 * alf1 * eps3der &
23798             + sigder * sigsq_om1     &
23799             + dCAVdOM1               &
23800             + dGCLdOM1               &
23801             + dPOLdOM1
23802
23803        eom2  =  &
23804               eps2der * eps2rt_om2   &
23805             + 2.0D0 * alf2 * eps3der &
23806             + sigder * sigsq_om2     &
23807             + dCAVdOM2               &
23808             + dGCLdOM2               &
23809             + dPOLdOM2
23810
23811        eom12 =    &
23812               evdwij  * eps1_om12     &
23813             + eps2der * eps2rt_om12   &
23814             - 2.0D0 * alf12 * eps3der &
23815             + sigder *sigsq_om12      &
23816             + dCAVdOM12               &
23817             + dGCLdOM12
23818 !        om12=0.0
23819 !        eom12=0.0
23820 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23821 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
23822 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23823 !                 *dsci_inv*2.0
23824 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23825 !               gg(1),gg(2),"rozne"
23826        DO k = 1, 3
23827         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23828         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
23829         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23830         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
23831                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
23832                  *dscj_inv*2.0 &
23833                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23834         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
23835                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
23836                  *dscj_inv*2.0 &
23837                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23838         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
23839                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
23840                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23841
23842 !         print *,eom12,eom2,om12,om2
23843 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23844 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23845 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
23846 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23847 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23848         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
23849        END DO
23850        RETURN
23851       END SUBROUTINE sc_grad_scpho
23852       subroutine eprot_pep_phosphate(epeppho)
23853       use calc_data
23854 !      implicit real*8 (a-h,o-z)
23855 !      include 'DIMENSIONS'
23856 !      include 'COMMON.GEO'
23857 !      include 'COMMON.VAR'
23858 !      include 'COMMON.LOCAL'
23859 !      include 'COMMON.CHAIN'
23860 !      include 'COMMON.DERIV'
23861 !      include 'COMMON.NAMES'
23862 !      include 'COMMON.INTERACT'
23863 !      include 'COMMON.IOUNITS'
23864 !      include 'COMMON.CALC'
23865 !      include 'COMMON.CONTROL'
23866 !      include 'COMMON.SBRIDGE'
23867       logical :: lprn
23868 !el local variables
23869       integer :: iint,itypi,itypi1,itypj,subchap
23870       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23871       real(kind=8) :: evdw,sig0ij
23872       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23873                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23874                     sslipi,sslipj,faclip
23875       integer :: ii
23876       real(kind=8) :: fracinbuf
23877        real (kind=8) :: epeppho
23878        real (kind=8),dimension(4):: ener
23879        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23880        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23881         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23882         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23883         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23884         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23885         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23886         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23887        real(kind=8),dimension(3,2)::chead,erhead_tail
23888        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23889        integer troll
23890        real (kind=8) :: dcosom1(3),dcosom2(3)
23891        epeppho=0.0d0
23892 !       do i=1,nres_molec(1)
23893         do i=ibond_start,ibond_end
23894         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23895         itypi  = itype(i,1)
23896         dsci_inv = vbld_inv(i+1)/2.0
23897         dxi    = dc_norm(1,i)
23898         dyi    = dc_norm(2,i)
23899         dzi    = dc_norm(3,i)
23900         xi=(c(1,i)+c(1,i+1))/2.0
23901         yi=(c(2,i)+c(2,i+1))/2.0
23902         zi=(c(3,i)+c(3,i+1))/2.0
23903         xi=mod(xi,boxxsize)
23904          if (xi.lt.0) xi=xi+boxxsize
23905         yi=mod(yi,boxysize)
23906          if (yi.lt.0) yi=yi+boxysize
23907         zi=mod(zi,boxzsize)
23908          if (zi.lt.0) zi=zi+boxzsize
23909          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23910            itypj= itype(j,2)
23911            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23912             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23913            xj=(c(1,j)+c(1,j+1))/2.0
23914            yj=(c(2,j)+c(2,j+1))/2.0
23915            zj=(c(3,j)+c(3,j+1))/2.0
23916            xj=dmod(xj,boxxsize)
23917            if (xj.lt.0) xj=xj+boxxsize
23918            yj=dmod(yj,boxysize)
23919            if (yj.lt.0) yj=yj+boxysize
23920            zj=dmod(zj,boxzsize)
23921            if (zj.lt.0) zj=zj+boxzsize
23922           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23923           xj_safe=xj
23924           yj_safe=yj
23925           zj_safe=zj
23926           subchap=0
23927           do xshift=-1,1
23928           do yshift=-1,1
23929           do zshift=-1,1
23930           yj=yj_safe+yshift*boxysize
23931           zj=zj_safe+zshift*boxzsize
23932           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23933           if(dist_temp.lt.dist_init) then
23934             dist_init=dist_temp
23935             xj_temp=xj
23936             yj_temp=yj
23937             zj_temp=zj
23938             subchap=1
23939           endif
23940           enddo
23941           enddo
23942           enddo
23943           if (subchap.eq.1) then
23944           xj=xj_temp-xi
23945           yj=yj_temp-yi
23946           zj=zj_temp-zi
23947           else
23948           xj=xj_safe-xi
23949           yj=yj_safe-yi
23950           zj=zj_safe-zi
23951           endif
23952           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23953           rij  = dsqrt(rrij)
23954           dxj = dc_norm( 1,j )
23955           dyj = dc_norm( 2,j )
23956           dzj = dc_norm( 3,j )
23957           dscj_inv = vbld_inv(j+1)/2.0
23958 ! Gay-berne var's
23959           sig0ij = sigma_peppho
23960           chi1=0.0d0
23961           chi2=0.0d0
23962           chi12  = chi1 * chi2
23963           chip1=0.0d0
23964           chip2=0.0d0
23965           chip12 = chip1 * chip2
23966           chis1 = 0.0d0
23967           chis2 = 0.0d0
23968           chis12 = chis1 * chis2
23969           sig1 = sigmap1_peppho
23970           sig2 = sigmap2_peppho
23971 !       write (*,*) "sig1 = ", sig1
23972 !       write (*,*) "sig1 = ", sig1
23973 !       write (*,*) "sig2 = ", sig2
23974 ! alpha factors from Fcav/Gcav
23975           alf1   = 0.0d0
23976           alf2   = 0.0d0
23977           alf12  = 0.0d0
23978           b1 = alphasur_peppho(1)
23979 !          b1=0.0d0
23980           b2 = alphasur_peppho(2)
23981           b3 = alphasur_peppho(3)
23982           b4 = alphasur_peppho(4)
23983           CALL sc_angular
23984        sqom1=om1*om1
23985        evdwij = 0.0d0
23986        ECL = 0.0d0
23987        Elj = 0.0d0
23988        Equad = 0.0d0
23989        Epol = 0.0d0
23990        Fcav=0.0d0
23991        eheadtail = 0.0d0
23992        dGCLdR=0.0d0
23993        dGCLdOM1 = 0.0d0
23994        dGCLdOM2 = 0.0d0
23995        dGCLdOM12 = 0.0d0
23996        dPOLdOM1 = 0.0d0
23997        dPOLdOM2 = 0.0d0
23998           Fcav = 0.0d0
23999           dFdR = 0.0d0
24000           dCAVdOM1  = 0.0d0
24001           dCAVdOM2  = 0.0d0
24002           dCAVdOM12 = 0.0d0
24003           rij_shift = rij
24004           fac       = rij_shift**expon
24005           c1        = fac  * fac * aa_peppho
24006 !          c1        = 0.0d0
24007           c2        = fac  * bb_peppho
24008 !          c2        = 0.0d0
24009           evdwij    =  c1 + c2
24010 ! Now cavity....................
24011        eagle = dsqrt(1.0/rij_shift)
24012        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24013           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24014           botsq = bot * bot
24015           Fcav = top / bot
24016           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24017           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24018           dFdR = ((dtop * bot - top * dbot) / botsq)
24019        w1        = wqdip_peppho(1)
24020        w2        = wqdip_peppho(2)
24021 !       w1=0.0d0
24022 !       w2=0.0d0
24023 !       pis       = sig0head_scbase(itypi,itypj)
24024 !       eps_head   = epshead_scbase(itypi,itypj)
24025 !c!-------------------------------------------------------------------
24026
24027 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24028 !c!     &        +dhead(1,1,itypi,itypj))**2))
24029 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24030 !c!     &        +dhead(2,1,itypi,itypj))**2))
24031
24032 !c!-------------------------------------------------------------------
24033 !c! ecl
24034        sparrow  = w1  *  om1
24035        hawk     = w2 *  (1.0d0 - sqom1)
24036        Ecl = sparrow * rij_shift**2.0d0 &
24037            - hawk    * rij_shift**4.0d0
24038 !c!-------------------------------------------------------------------
24039 !c! derivative of ecl is Gcl
24040 !c! dF/dr part
24041 !       rij_shift=5.0
24042        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24043                 + 4.0d0 * hawk    * rij_shift**5.0d0
24044 !c! dF/dom1
24045        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24046 !c! dF/dom2
24047        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24048        eom1  =    dGCLdOM1+dGCLdOM2
24049        eom2  =    0.0
24050
24051           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24052 !          fac=0.0
24053           gg(1) =  fac*xj*rij
24054           gg(2) =  fac*yj*rij
24055           gg(3) =  fac*zj*rij
24056          do k=1,3
24057          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24058          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24059          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24060          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24061          gg(k)=0.0
24062          enddo
24063
24064       DO k = 1, 3
24065         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24066         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24067         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24068         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24069 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24070         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24071 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24072         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24073                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24074         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24075                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24076         enddo
24077        epeppho=epeppho+evdwij+Fcav+ECL
24078 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24079        enddo
24080        enddo
24081       end subroutine eprot_pep_phosphate
24082       end module energy