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 !      write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 608 !      print *,"before",ees,evdw1,ecorr
 609       if (nres_molec(2).gt.0) then
 610       call ebond_nucl(estr_nucl)
 611       call ebend_nucl(ebe_nucl)
 612       call etor_nucl(etors_nucl)
 613       call esb_gb(evdwsb,eelsb)
 614       call epp_nucl_sub(evdwpp,eespp)
 615       call epsb(evdwpsb,eelpsb)
 616       call esb(esbloc)
 617       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 618       else
 619        etors_nucl=0.0d0
 620        estr_nucl=0.0d0
 621        ebe_nucl=0.0d0
 622        evdwsb=0.0d0
 623        eelsb=0.0d0
 624        esbloc=0.0d0
 625       endif
 626       if (nfgtasks.gt.1) then
 627       if (fg_rank.eq.0) then
 628       call ecatcat(ecationcation)
 629       endif
 630       else
 631       call ecatcat(ecationcation)
 632       endif
 633       call ecat_prot(ecation_prot)
 634       if (nres_molec(2).gt.0) then
 635       call eprot_sc_base(escbase)
 636       call epep_sc_base(epepbase)
 637       call eprot_sc_phosphate(escpho)
 638       call eprot_pep_phosphate(epeppho)
 639       endif
 640 !      call ecatcat(ecationcation)
 641 !      print *,"after ebend", ebe_nucl
 642 #ifdef TIMING
 643       time_enecalc=time_enecalc+MPI_Wtime()-time00
 644 #endif
 645 !      print *,"Processor",myrank," computed Uconstr"
 646 #ifdef TIMING
 647       time00=MPI_Wtime()
 648 #endif
 649 !
 650 ! Sum the energies
 651 !
 652       energia(1)=evdw
 653 #ifdef SCP14
 654       energia(2)=evdw2-evdw2_14
 655       energia(18)=evdw2_14
 656 #else
 657       energia(2)=evdw2
 658       energia(18)=0.0d0
 659 #endif
 660 #ifdef SPLITELE
 661       energia(3)=ees
 662       energia(16)=evdw1
 663 #else
 664       energia(3)=ees+evdw1
 665       energia(16)=0.0d0
 666 #endif
 667       energia(4)=ecorr
 668       energia(5)=ecorr5
 669       energia(6)=ecorr6
 670       energia(7)=eel_loc
 671       energia(8)=eello_turn3
 672       energia(9)=eello_turn4
 673       energia(10)=eturn6
 674       energia(11)=ebe
 675       energia(12)=escloc
 676       energia(13)=etors
 677       energia(14)=etors_d
 678       energia(15)=ehpb
 679       energia(19)=edihcnstr
 680       energia(17)=estr
 681       energia(20)=Uconst+Uconst_back
 682       energia(21)=esccor
 683       energia(22)=eliptran
 684       energia(23)=Eafmforce
 685       energia(24)=ethetacnstr
 686       energia(25)=etube
 687 !---------------------------------------------------------------
 688       energia(26)=evdwpp
 689       energia(27)=eespp
 690       energia(28)=evdwpsb
 691       energia(29)=eelpsb
 692       energia(30)=evdwsb
 693       energia(31)=eelsb
 694       energia(32)=estr_nucl
 695       energia(33)=ebe_nucl
 696       energia(34)=esbloc
 697       energia(35)=etors_nucl
 698       energia(36)=etors_d_nucl
 699       energia(37)=ecorr_nucl
 700       energia(38)=ecorr3_nucl
 701 !----------------------------------------------------------------------
 702 !    Here are the energies showed per procesor if the are more processors
 703 !    per molecule then we sum it up in sum_energy subroutine
 704 !      print *," Processor",myrank," calls SUM_ENERGY"
 705       energia(41)=ecation_prot
 706       energia(42)=ecationcation
 707       energia(46)=escbase
 708       energia(47)=epepbase
 709       energia(48)=escpho
 710       energia(49)=epeppho
 711       call sum_energy(energia,.true.)
 712       if (dyn_ss) call dyn_set_nss
 713 !      print *," Processor",myrank," left SUM_ENERGY"
 714 #ifdef TIMING
 715       time_sumene=time_sumene+MPI_Wtime()-time00
 716 #endif
 717 !el        call enerprint(energia)
 718 !elwrite(iout,*)"finish etotal"
 719       return
 720       end subroutine etotal
 721 !-----------------------------------------------------------------------------
 722       subroutine sum_energy(energia,reduce)
 723 !      implicit real*8 (a-h,o-z)
 724 !      include 'DIMENSIONS'
 725 #ifndef ISNAN
 726       external proc_proc
 727 #ifdef WINPGI
 728 !MS$ATTRIBUTES C ::  proc_proc
 729 #endif
 730 #endif
 731 #ifdef MPI
 732       include "mpif.h"
 733 #endif
 734 !      include 'COMMON.SETUP'
 735 !      include 'COMMON.IOUNITS'
 736       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 737 !      include 'COMMON.FFIELD'
 738 !      include 'COMMON.DERIV'
 739 !      include 'COMMON.INTERACT'
 740 !      include 'COMMON.SBRIDGE'
 741 !      include 'COMMON.CHAIN'
 742 !      include 'COMMON.VAR'
 743 !      include 'COMMON.CONTROL'
 744 !      include 'COMMON.TIME1'
 745       logical :: reduce
 746       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 747       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 748       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 749         eliptran,etube, Eafmforce,ethetacnstr
 750       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 751                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 752                       ecorr3_nucl
 753       real(kind=8) :: ecation_prot,ecationcation
 754       real(kind=8) :: escbase,epepbase,escpho,epeppho
 755       integer :: i
 756 #ifdef MPI
 757       integer :: ierr
 758       real(kind=8) :: time00
 759       if (nfgtasks.gt.1 .and. reduce) then
 760
 761 #ifdef DEBUG
 762         write (iout,*) "energies before REDUCE"
 763         call enerprint(energia)
 764         call flush(iout)
 765 #endif
 766         do i=0,n_ene
 767           enebuff(i)=energia(i)
 768         enddo
 769         time00=MPI_Wtime()
 770         call MPI_Barrier(FG_COMM,IERR)
 771         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 772         time00=MPI_Wtime()
 773         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 774           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 775 #ifdef DEBUG
 776         write (iout,*) "energies after REDUCE"
 777         call enerprint(energia)
 778         call flush(iout)
 779 #endif
 780         time_Reduce=time_Reduce+MPI_Wtime()-time00
 781       endif
 782       if (fg_rank.eq.0) then
 783 #endif
 784       evdw=energia(1)
 785 #ifdef SCP14
 786       evdw2=energia(2)+energia(18)
 787       evdw2_14=energia(18)
 788 #else
 789       evdw2=energia(2)
 790 #endif
 791 #ifdef SPLITELE
 792       ees=energia(3)
 793       evdw1=energia(16)
 794 #else
 795       ees=energia(3)
 796       evdw1=0.0d0
 797 #endif
 798       ecorr=energia(4)
 799       ecorr5=energia(5)
 800       ecorr6=energia(6)
 801       eel_loc=energia(7)
 802       eello_turn3=energia(8)
 803       eello_turn4=energia(9)
 804       eturn6=energia(10)
 805       ebe=energia(11)
 806       escloc=energia(12)
 807       etors=energia(13)
 808       etors_d=energia(14)
 809       ehpb=energia(15)
 810       edihcnstr=energia(19)
 811       estr=energia(17)
 812       Uconst=energia(20)
 813       esccor=energia(21)
 814       eliptran=energia(22)
 815       Eafmforce=energia(23)
 816       ethetacnstr=energia(24)
 817       etube=energia(25)
 818       evdwpp=energia(26)
 819       eespp=energia(27)
 820       evdwpsb=energia(28)
 821       eelpsb=energia(29)
 822       evdwsb=energia(30)
 823       eelsb=energia(31)
 824       estr_nucl=energia(32)
 825       ebe_nucl=energia(33)
 826       esbloc=energia(34)
 827       etors_nucl=energia(35)
 828       etors_d_nucl=energia(36)
 829       ecorr_nucl=energia(37)
 830       ecorr3_nucl=energia(38)
 831       ecation_prot=energia(41)
 832       ecationcation=energia(42)
 833       escbase=energia(46)
 834       epepbase=energia(47)
 835       escpho=energia(48)
 836       epeppho=energia(49)
 837 !      energia(41)=ecation_prot
 838 !      energia(42)=ecationcation
 839
 840
 841 #ifdef SPLITELE
 842       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 843        +wang*ebe+wtor*etors+wscloc*escloc &
 844        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 845        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 846        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 847        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 848        +Eafmforce+ethetacnstr  &
 849        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 850        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 851        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 852        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 853        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 854        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 855 #else
 856       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 857        +wang*ebe+wtor*etors+wscloc*escloc &
 858        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 859        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 860        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 861        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 862        +Eafmforce+ethetacnstr &
 863        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 864        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 865        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 866        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 867        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 868        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 869 #endif
 870       energia(0)=etot
 871 ! detecting NaNQ
 872 #ifdef ISNAN
 873 #ifdef AIX
 874       if (isnan(etot).ne.0) energia(0)=1.0d+99
 875 #else
 876       if (isnan(etot)) energia(0)=1.0d+99
 877 #endif
 878 #else
 879       i=0
 880 #ifdef WINPGI
 881       idumm=proc_proc(etot,i)
 882 #else
 883       call proc_proc(etot,i)
 884 #endif
 885       if(i.eq.1)energia(0)=1.0d+99
 886 #endif
 887 #ifdef MPI
 888       endif
 889 #endif
 890 !      call enerprint(energia)
 891       call flush(iout)
 892       return
 893       end subroutine sum_energy
 894 !-----------------------------------------------------------------------------
 895       subroutine rescale_weights(t_bath)
 896 !      implicit real*8 (a-h,o-z)
 897 #ifdef MPI
 898       include 'mpif.h'
 899 #endif
 900 !      include 'DIMENSIONS'
 901 !      include 'COMMON.IOUNITS'
 902 !      include 'COMMON.FFIELD'
 903 !      include 'COMMON.SBRIDGE'
 904       real(kind=8) :: kfac=2.4d0
 905       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 906 !el local variables
 907       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 908       real(kind=8) :: T0=3.0d2
 909       integer :: ierror
 910 !      facT=temp0/t_bath
 911 !      facT=2*temp0/(t_bath+temp0)
 912       if (rescale_mode.eq.0) then
 913         facT(1)=1.0d0
 914         facT(2)=1.0d0
 915         facT(3)=1.0d0
 916         facT(4)=1.0d0
 917         facT(5)=1.0d0
 918         facT(6)=1.0d0
 919       else if (rescale_mode.eq.1) then
 920         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 921         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 922         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 923         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 924         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 925 #ifdef WHAM_RUN
 926 !#if defined(WHAM_RUN) || defined(CLUSTER)
 927 #if defined(FUNCTH)
 928 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 929         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 930 #elif defined(FUNCT)
 931         facT(6)=t_bath/T0
 932 #else
 933         facT(6)=1.0d0
 934 #endif
 935 #endif
 936       else if (rescale_mode.eq.2) then
 937         x=t_bath/temp0
 938         x2=x*x
 939         x3=x2*x
 940         x4=x3*x
 941         x5=x4*x
 942         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 943         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 944         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 945         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 946         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 947 #ifdef WHAM_RUN
 948 !#if defined(WHAM_RUN) || defined(CLUSTER)
 949 #if defined(FUNCTH)
 950         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 951 #elif defined(FUNCT)
 952         facT(6)=t_bath/T0
 953 #else
 954         facT(6)=1.0d0
 955 #endif
 956 #endif
 957       else
 958         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 959         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 960 #ifdef MPI
 961        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 962 #endif
 963        stop 555
 964       endif
 965       welec=weights(3)*fact(1)
 966       wcorr=weights(4)*fact(3)
 967       wcorr5=weights(5)*fact(4)
 968       wcorr6=weights(6)*fact(5)
 969       wel_loc=weights(7)*fact(2)
 970       wturn3=weights(8)*fact(2)
 971       wturn4=weights(9)*fact(3)
 972       wturn6=weights(10)*fact(5)
 973       wtor=weights(13)*fact(1)
 974       wtor_d=weights(14)*fact(2)
 975       wsccor=weights(21)*fact(1)
 976
 977       return
 978       end subroutine rescale_weights
 979 !-----------------------------------------------------------------------------
 980       subroutine enerprint(energia)
 981 !      implicit real*8 (a-h,o-z)
 982 !      include 'DIMENSIONS'
 983 !      include 'COMMON.IOUNITS'
 984 !      include 'COMMON.FFIELD'
 985 !      include 'COMMON.SBRIDGE'
 986 !      include 'COMMON.MD'
 987       real(kind=8) :: energia(0:n_ene)
 988 !el local variables
 989       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 990       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 991       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 992        etube,ethetacnstr,Eafmforce
 993       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 994                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 995                       ecorr3_nucl
 996       real(kind=8) :: ecation_prot,ecationcation
 997       real(kind=8) :: escbase,epepbase,escpho,epeppho
 998
 999       etot=energia(0)
1000       evdw=energia(1)
1001       evdw2=energia(2)
1002 #ifdef SCP14
1003       evdw2=energia(2)+energia(18)
1004 #else
1005       evdw2=energia(2)
1006 #endif
1007       ees=energia(3)
1008 #ifdef SPLITELE
1009       evdw1=energia(16)
1010 #endif
1011       ecorr=energia(4)
1012       ecorr5=energia(5)
1013       ecorr6=energia(6)
1014       eel_loc=energia(7)
1015       eello_turn3=energia(8)
1016       eello_turn4=energia(9)
1017       eello_turn6=energia(10)
1018       ebe=energia(11)
1019       escloc=energia(12)
1020       etors=energia(13)
1021       etors_d=energia(14)
1022       ehpb=energia(15)
1023       edihcnstr=energia(19)
1024       estr=energia(17)
1025       Uconst=energia(20)
1026       esccor=energia(21)
1027       eliptran=energia(22)
1028       Eafmforce=energia(23)
1029       ethetacnstr=energia(24)
1030       etube=energia(25)
1031       evdwpp=energia(26)
1032       eespp=energia(27)
1033       evdwpsb=energia(28)
1034       eelpsb=energia(29)
1035       evdwsb=energia(30)
1036       eelsb=energia(31)
1037       estr_nucl=energia(32)
1038       ebe_nucl=energia(33)
1039       esbloc=energia(34)
1040       etors_nucl=energia(35)
1041       etors_d_nucl=energia(36)
1042       ecorr_nucl=energia(37)
1043       ecorr3_nucl=energia(38)
1044       ecation_prot=energia(41)
1045       ecationcation=energia(42)
1046       escbase=energia(46)
1047       epepbase=energia(47)
1048       escpho=energia(48)
1049       epeppho=energia(49)
1050 #ifdef SPLITELE
1051       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1052         estr,wbond,ebe,wang,&
1053         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1054         ecorr,wcorr,&
1055         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1056         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1057         edihcnstr,ethetacnstr,ebr*nss,&
1058         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1059         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1060         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1061         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1062         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1063         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1064         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1065         etot
1066    10 format (/'Virtual-chain energies:'// &
1067        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1068        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1069        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1070        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1071        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1072        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1073        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1074        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1075        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1076        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1077        ' (SS bridges & dist. cnstr.)'/ &
1078        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1079        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1080        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1081        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1082        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1083        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1084        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1085        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1086        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1087        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1088        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1089        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1090        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1091        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1092        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1093        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1094        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1095        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1096        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1097        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1098        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1099        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1100        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1101        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1102        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1103        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1104        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1105        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1106        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1107        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1108        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1109        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1110        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1111        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1112        'ETOT=  ',1pE16.6,' (total)')
1113 #else
1114       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1115         estr,wbond,ebe,wang,&
1116         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1117         ecorr,wcorr,&
1118         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1119         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1120         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1121         etube,wtube, &
1122         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1123         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1124         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1125         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1126         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1127         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1128         etot
1129    10 format (/'Virtual-chain energies:'// &
1130        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1131        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1132        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1133        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1134        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1135        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1136        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1137        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1138        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1139        ' (SS bridges & dist. cnstr.)'/ &
1140        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1141        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1142        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1143        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1144        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1145        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1146        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1147        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1148        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1149        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1150        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1151        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1152        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1153        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1154        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1155        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1156        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1157        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1158        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1159        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1160        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1161        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1162        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1163        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1164        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1165        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1166        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1167        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1168        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1169        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1170        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1171        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1172        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1173        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1174        'ETOT=  ',1pE16.6,' (total)')
1175 #endif
1176       return
1177       end subroutine enerprint
1178 !-----------------------------------------------------------------------------
1179       subroutine elj(evdw)
1180 !
1181 ! This subroutine calculates the interaction energy of nonbonded side chains
1182 ! assuming the LJ potential of interaction.
1183 !
1184 !      implicit real*8 (a-h,o-z)
1185 !      include 'DIMENSIONS'
1186       real(kind=8),parameter :: accur=1.0d-10
1187 !      include 'COMMON.GEO'
1188 !      include 'COMMON.VAR'
1189 !      include 'COMMON.LOCAL'
1190 !      include 'COMMON.CHAIN'
1191 !      include 'COMMON.DERIV'
1192 !      include 'COMMON.INTERACT'
1193 !      include 'COMMON.TORSION'
1194 !      include 'COMMON.SBRIDGE'
1195 !      include 'COMMON.NAMES'
1196 !      include 'COMMON.IOUNITS'
1197 !      include 'COMMON.CONTACTS'
1198       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1199       integer :: num_conti
1200 !el local variables
1201       integer :: i,itypi,iint,j,itypi1,itypj,k
1202       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1203       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1204       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1205
1206 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1207       evdw=0.0D0
1208 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1209 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1210 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1211 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1212
1213       do i=iatsc_s,iatsc_e
1214         itypi=iabs(itype(i,1))
1215         if (itypi.eq.ntyp1) cycle
1216         itypi1=iabs(itype(i+1,1))
1217         xi=c(1,nres+i)
1218         yi=c(2,nres+i)
1219         zi=c(3,nres+i)
1220 ! Change 12/1/95
1221         num_conti=0
1222 !
1223 ! Calculate SC interaction energy.
1224 !
1225         do iint=1,nint_gr(i)
1226 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1227 !d   &                  'iend=',iend(i,iint)
1228           do j=istart(i,iint),iend(i,iint)
1229             itypj=iabs(itype(j,1))
1230             if (itypj.eq.ntyp1) cycle
1231             xj=c(1,nres+j)-xi
1232             yj=c(2,nres+j)-yi
1233             zj=c(3,nres+j)-zi
1234 ! Change 12/1/95 to calculate four-body interactions
1235             rij=xj*xj+yj*yj+zj*zj
1236             rrij=1.0D0/rij
1237 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1238             eps0ij=eps(itypi,itypj)
1239             fac=rrij**expon2
1240             e1=fac*fac*aa_aq(itypi,itypj)
1241             e2=fac*bb_aq(itypi,itypj)
1242             evdwij=e1+e2
1243 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1244 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1245 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1246 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1247 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1248 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1249             evdw=evdw+evdwij
1250 !
1251 ! Calculate the components of the gradient in DC and X
1252 !
1253             fac=-rrij*(e1+evdwij)
1254             gg(1)=xj*fac
1255             gg(2)=yj*fac
1256             gg(3)=zj*fac
1257             do k=1,3
1258               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1259               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1260               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1261               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1262             enddo
1263 !grad            do k=i,j-1
1264 !grad              do l=1,3
1265 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1266 !grad              enddo
1267 !grad            enddo
1268 !
1269 ! 12/1/95, revised on 5/20/97
1270 !
1271 ! Calculate the contact function. The ith column of the array JCONT will
1272 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1273 ! greater than I). The arrays FACONT and GACONT will contain the values of
1274 ! the contact function and its derivative.
1275 !
1276 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1277 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1278 ! Uncomment next line, if the correlation interactions are contact function only
1279             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1280               rij=dsqrt(rij)
1281               sigij=sigma(itypi,itypj)
1282               r0ij=rs0(itypi,itypj)
1283 !
1284 ! Check whether the SC's are not too far to make a contact.
1285 !
1286               rcut=1.5d0*r0ij
1287               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1288 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1289 !
1290               if (fcont.gt.0.0D0) then
1291 ! If the SC-SC distance if close to sigma, apply spline.
1292 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1293 !Adam &             fcont1,fprimcont1)
1294 !Adam           fcont1=1.0d0-fcont1
1295 !Adam           if (fcont1.gt.0.0d0) then
1296 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1297 !Adam             fcont=fcont*fcont1
1298 !Adam           endif
1299 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1300 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1301 !ga             do k=1,3
1302 !ga               gg(k)=gg(k)*eps0ij
1303 !ga             enddo
1304 !ga             eps0ij=-evdwij*eps0ij
1305 ! Uncomment for AL's type of SC correlation interactions.
1306 !adam           eps0ij=-evdwij
1307                 num_conti=num_conti+1
1308                 jcont(num_conti,i)=j
1309                 facont(num_conti,i)=fcont*eps0ij
1310                 fprimcont=eps0ij*fprimcont/rij
1311                 fcont=expon*fcont
1312 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1313 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1314 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1315 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1316                 gacont(1,num_conti,i)=-fprimcont*xj
1317                 gacont(2,num_conti,i)=-fprimcont*yj
1318                 gacont(3,num_conti,i)=-fprimcont*zj
1319 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1320 !d              write (iout,'(2i3,3f10.5)')
1321 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1322               endif
1323             endif
1324           enddo      ! j
1325         enddo        ! iint
1326 ! Change 12/1/95
1327         num_cont(i)=num_conti
1328       enddo          ! i
1329       do i=1,nct
1330         do j=1,3
1331           gvdwc(j,i)=expon*gvdwc(j,i)
1332           gvdwx(j,i)=expon*gvdwx(j,i)
1333         enddo
1334       enddo
1335 !******************************************************************************
1336 !
1337 !                              N O T E !!!
1338 !
1339 ! To save time, the factor of EXPON has been extracted from ALL components
1340 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1341 ! use!
1342 !
1343 !******************************************************************************
1344       return
1345       end subroutine elj
1346 !-----------------------------------------------------------------------------
1347       subroutine eljk(evdw)
1348 !
1349 ! This subroutine calculates the interaction energy of nonbonded side chains
1350 ! assuming the LJK potential of interaction.
1351 !
1352 !      implicit real*8 (a-h,o-z)
1353 !      include 'DIMENSIONS'
1354 !      include 'COMMON.GEO'
1355 !      include 'COMMON.VAR'
1356 !      include 'COMMON.LOCAL'
1357 !      include 'COMMON.CHAIN'
1358 !      include 'COMMON.DERIV'
1359 !      include 'COMMON.INTERACT'
1360 !      include 'COMMON.IOUNITS'
1361 !      include 'COMMON.NAMES'
1362       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1363       logical :: scheck
1364 !el local variables
1365       integer :: i,iint,j,itypi,itypi1,k,itypj
1366       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1367       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1368
1369 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1370       evdw=0.0D0
1371       do i=iatsc_s,iatsc_e
1372         itypi=iabs(itype(i,1))
1373         if (itypi.eq.ntyp1) cycle
1374         itypi1=iabs(itype(i+1,1))
1375         xi=c(1,nres+i)
1376         yi=c(2,nres+i)
1377         zi=c(3,nres+i)
1378 !
1379 ! Calculate SC interaction energy.
1380 !
1381         do iint=1,nint_gr(i)
1382           do j=istart(i,iint),iend(i,iint)
1383             itypj=iabs(itype(j,1))
1384             if (itypj.eq.ntyp1) cycle
1385             xj=c(1,nres+j)-xi
1386             yj=c(2,nres+j)-yi
1387             zj=c(3,nres+j)-zi
1388             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1389             fac_augm=rrij**expon
1390             e_augm=augm(itypi,itypj)*fac_augm
1391             r_inv_ij=dsqrt(rrij)
1392             rij=1.0D0/r_inv_ij
1393             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1394             fac=r_shift_inv**expon
1395             e1=fac*fac*aa_aq(itypi,itypj)
1396             e2=fac*bb_aq(itypi,itypj)
1397             evdwij=e_augm+e1+e2
1398 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1399 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1400 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1401 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1402 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1403 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1404 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1405             evdw=evdw+evdwij
1406 !
1407 ! Calculate the components of the gradient in DC and X
1408 !
1409             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1410             gg(1)=xj*fac
1411             gg(2)=yj*fac
1412             gg(3)=zj*fac
1413             do k=1,3
1414               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1415               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1416               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1417               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1418             enddo
1419 !grad            do k=i,j-1
1420 !grad              do l=1,3
1421 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1422 !grad              enddo
1423 !grad            enddo
1424           enddo      ! j
1425         enddo        ! iint
1426       enddo          ! i
1427       do i=1,nct
1428         do j=1,3
1429           gvdwc(j,i)=expon*gvdwc(j,i)
1430           gvdwx(j,i)=expon*gvdwx(j,i)
1431         enddo
1432       enddo
1433       return
1434       end subroutine eljk
1435 !-----------------------------------------------------------------------------
1436       subroutine ebp(evdw)
1437 !
1438 ! This subroutine calculates the interaction energy of nonbonded side chains
1439 ! assuming the Berne-Pechukas potential of interaction.
1440 !
1441       use comm_srutu
1442       use calc_data
1443 !      implicit real*8 (a-h,o-z)
1444 !      include 'DIMENSIONS'
1445 !      include 'COMMON.GEO'
1446 !      include 'COMMON.VAR'
1447 !      include 'COMMON.LOCAL'
1448 !      include 'COMMON.CHAIN'
1449 !      include 'COMMON.DERIV'
1450 !      include 'COMMON.NAMES'
1451 !      include 'COMMON.INTERACT'
1452 !      include 'COMMON.IOUNITS'
1453 !      include 'COMMON.CALC'
1454       use comm_srutu
1455 !el      integer :: icall
1456 !el      common /srutu/ icall
1457 !     double precision rrsave(maxdim)
1458       logical :: lprn
1459 !el local variables
1460       integer :: iint,itypi,itypi1,itypj
1461       real(kind=8) :: rrij,xi,yi,zi
1462       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1463
1464 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1465       evdw=0.0D0
1466 !     if (icall.eq.0) then
1467 !       lprn=.true.
1468 !     else
1469         lprn=.false.
1470 !     endif
1471 !el      ind=0
1472       do i=iatsc_s,iatsc_e
1473         itypi=iabs(itype(i,1))
1474         if (itypi.eq.ntyp1) cycle
1475         itypi1=iabs(itype(i+1,1))
1476         xi=c(1,nres+i)
1477         yi=c(2,nres+i)
1478         zi=c(3,nres+i)
1479         dxi=dc_norm(1,nres+i)
1480         dyi=dc_norm(2,nres+i)
1481         dzi=dc_norm(3,nres+i)
1482 !        dsci_inv=dsc_inv(itypi)
1483         dsci_inv=vbld_inv(i+nres)
1484 !
1485 ! Calculate SC interaction energy.
1486 !
1487         do iint=1,nint_gr(i)
1488           do j=istart(i,iint),iend(i,iint)
1489 !el            ind=ind+1
1490             itypj=iabs(itype(j,1))
1491             if (itypj.eq.ntyp1) cycle
1492 !            dscj_inv=dsc_inv(itypj)
1493             dscj_inv=vbld_inv(j+nres)
1494             chi1=chi(itypi,itypj)
1495             chi2=chi(itypj,itypi)
1496             chi12=chi1*chi2
1497             chip1=chip(itypi)
1498             chip2=chip(itypj)
1499             chip12=chip1*chip2
1500             alf1=alp(itypi)
1501             alf2=alp(itypj)
1502             alf12=0.5D0*(alf1+alf2)
1503 ! For diagnostics only!!!
1504 !           chi1=0.0D0
1505 !           chi2=0.0D0
1506 !           chi12=0.0D0
1507 !           chip1=0.0D0
1508 !           chip2=0.0D0
1509 !           chip12=0.0D0
1510 !           alf1=0.0D0
1511 !           alf2=0.0D0
1512 !           alf12=0.0D0
1513             xj=c(1,nres+j)-xi
1514             yj=c(2,nres+j)-yi
1515             zj=c(3,nres+j)-zi
1516             dxj=dc_norm(1,nres+j)
1517             dyj=dc_norm(2,nres+j)
1518             dzj=dc_norm(3,nres+j)
1519             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1520 !d          if (icall.eq.0) then
1521 !d            rrsave(ind)=rrij
1522 !d          else
1523 !d            rrij=rrsave(ind)
1524 !d          endif
1525             rij=dsqrt(rrij)
1526 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1527             call sc_angular
1528 ! Calculate whole angle-dependent part of epsilon and contributions
1529 ! to its derivatives
1530             fac=(rrij*sigsq)**expon2
1531             e1=fac*fac*aa_aq(itypi,itypj)
1532             e2=fac*bb_aq(itypi,itypj)
1533             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1534             eps2der=evdwij*eps3rt
1535             eps3der=evdwij*eps2rt
1536             evdwij=evdwij*eps2rt*eps3rt
1537             evdw=evdw+evdwij
1538             if (lprn) then
1539             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1540             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1541 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1542 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1543 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1544 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1545 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1546 !d     &        evdwij
1547             endif
1548 ! Calculate gradient components.
1549             e1=e1*eps1*eps2rt**2*eps3rt**2
1550             fac=-expon*(e1+evdwij)
1551             sigder=fac/sigsq
1552             fac=rrij*fac
1553 ! Calculate radial part of the gradient
1554             gg(1)=xj*fac
1555             gg(2)=yj*fac
1556             gg(3)=zj*fac
1557 ! Calculate the angular part of the gradient and sum add the contributions
1558 ! to the appropriate components of the Cartesian gradient.
1559             call sc_grad
1560           enddo      ! j
1561         enddo        ! iint
1562       enddo          ! i
1563 !     stop
1564       return
1565       end subroutine ebp
1566 !-----------------------------------------------------------------------------
1567       subroutine egb(evdw)
1568 !
1569 ! This subroutine calculates the interaction energy of nonbonded side chains
1570 ! assuming the Gay-Berne potential of interaction.
1571 !
1572       use calc_data
1573 !      implicit real*8 (a-h,o-z)
1574 !      include 'DIMENSIONS'
1575 !      include 'COMMON.GEO'
1576 !      include 'COMMON.VAR'
1577 !      include 'COMMON.LOCAL'
1578 !      include 'COMMON.CHAIN'
1579 !      include 'COMMON.DERIV'
1580 !      include 'COMMON.NAMES'
1581 !      include 'COMMON.INTERACT'
1582 !      include 'COMMON.IOUNITS'
1583 !      include 'COMMON.CALC'
1584 !      include 'COMMON.CONTROL'
1585 !      include 'COMMON.SBRIDGE'
1586       logical :: lprn
1587 !el local variables
1588       integer :: iint,itypi,itypi1,itypj,subchap
1589       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1590       real(kind=8) :: evdw,sig0ij
1591       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1592                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1593                     sslipi,sslipj,faclip
1594       integer :: ii
1595       real(kind=8) :: fracinbuf
1596
1597 !cccc      energy_dec=.false.
1598 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1599       evdw=0.0D0
1600       lprn=.false.
1601 !     if (icall.eq.0) lprn=.false.
1602 !el      ind=0
1603       do i=iatsc_s,iatsc_e
1604 !C        print *,"I am in EVDW",i
1605         itypi=iabs(itype(i,1))
1606 !        if (i.ne.47) cycle
1607         if (itypi.eq.ntyp1) cycle
1608         itypi1=iabs(itype(i+1,1))
1609         xi=c(1,nres+i)
1610         yi=c(2,nres+i)
1611         zi=c(3,nres+i)
1612           xi=dmod(xi,boxxsize)
1613           if (xi.lt.0) xi=xi+boxxsize
1614           yi=dmod(yi,boxysize)
1615           if (yi.lt.0) yi=yi+boxysize
1616           zi=dmod(zi,boxzsize)
1617           if (zi.lt.0) zi=zi+boxzsize
1618
1619        if ((zi.gt.bordlipbot)  &
1620         .and.(zi.lt.bordliptop)) then
1621 !C the energy transfer exist
1622         if (zi.lt.buflipbot) then
1623 !C what fraction I am in
1624          fracinbuf=1.0d0-  &
1625               ((zi-bordlipbot)/lipbufthick)
1626 !C lipbufthick is thickenes of lipid buffore
1627          sslipi=sscalelip(fracinbuf)
1628          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1629         elseif (zi.gt.bufliptop) then
1630          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1631          sslipi=sscalelip(fracinbuf)
1632          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1633         else
1634          sslipi=1.0d0
1635          ssgradlipi=0.0
1636         endif
1637        else
1638          sslipi=0.0d0
1639          ssgradlipi=0.0
1640        endif
1641 !       print *, sslipi,ssgradlipi
1642         dxi=dc_norm(1,nres+i)
1643         dyi=dc_norm(2,nres+i)
1644         dzi=dc_norm(3,nres+i)
1645 !        dsci_inv=dsc_inv(itypi)
1646         dsci_inv=vbld_inv(i+nres)
1647 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1648 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1649 !
1650 ! Calculate SC interaction energy.
1651 !
1652         do iint=1,nint_gr(i)
1653           do j=istart(i,iint),iend(i,iint)
1654             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1655               call dyn_ssbond_ene(i,j,evdwij)
1656               evdw=evdw+evdwij
1657               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1658                               'evdw',i,j,evdwij,' ss'
1659 !              if (energy_dec) write (iout,*) &
1660 !                              'evdw',i,j,evdwij,' ss'
1661              do k=j+1,iend(i,iint)
1662 !C search over all next residues
1663               if (dyn_ss_mask(k)) then
1664 !C check if they are cysteins
1665 !C              write(iout,*) 'k=',k
1666
1667 !c              write(iout,*) "PRZED TRI", evdwij
1668 !               evdwij_przed_tri=evdwij
1669               call triple_ssbond_ene(i,j,k,evdwij)
1670 !c               if(evdwij_przed_tri.ne.evdwij) then
1671 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1672 !c               endif
1673
1674 !c              write(iout,*) "PO TRI", evdwij
1675 !C call the energy function that removes the artifical triple disulfide
1676 !C bond the soubroutine is located in ssMD.F
1677               evdw=evdw+evdwij
1678               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1679                             'evdw',i,j,evdwij,'tss'
1680               endif!dyn_ss_mask(k)
1681              enddo! k
1682             ELSE
1683 !el            ind=ind+1
1684             itypj=iabs(itype(j,1))
1685             if (itypj.eq.ntyp1) cycle
1686 !             if (j.ne.78) cycle
1687 !            dscj_inv=dsc_inv(itypj)
1688             dscj_inv=vbld_inv(j+nres)
1689 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1690 !              1.0d0/vbld(j+nres) !d
1691 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1692             sig0ij=sigma(itypi,itypj)
1693             chi1=chi(itypi,itypj)
1694             chi2=chi(itypj,itypi)
1695             chi12=chi1*chi2
1696             chip1=chip(itypi)
1697             chip2=chip(itypj)
1698             chip12=chip1*chip2
1699             alf1=alp(itypi)
1700             alf2=alp(itypj)
1701             alf12=0.5D0*(alf1+alf2)
1702 ! For diagnostics only!!!
1703 !           chi1=0.0D0
1704 !           chi2=0.0D0
1705 !           chi12=0.0D0
1706 !           chip1=0.0D0
1707 !           chip2=0.0D0
1708 !           chip12=0.0D0
1709 !           alf1=0.0D0
1710 !           alf2=0.0D0
1711 !           alf12=0.0D0
1712            xj=c(1,nres+j)
1713            yj=c(2,nres+j)
1714            zj=c(3,nres+j)
1715           xj=dmod(xj,boxxsize)
1716           if (xj.lt.0) xj=xj+boxxsize
1717           yj=dmod(yj,boxysize)
1718           if (yj.lt.0) yj=yj+boxysize
1719           zj=dmod(zj,boxzsize)
1720           if (zj.lt.0) zj=zj+boxzsize
1721 !          print *,"tu",xi,yi,zi,xj,yj,zj
1722 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1723 ! this fragment set correct epsilon for lipid phase
1724        if ((zj.gt.bordlipbot)  &
1725        .and.(zj.lt.bordliptop)) then
1726 !C the energy transfer exist
1727         if (zj.lt.buflipbot) then
1728 !C what fraction I am in
1729          fracinbuf=1.0d0-     &
1730              ((zj-bordlipbot)/lipbufthick)
1731 !C lipbufthick is thickenes of lipid buffore
1732          sslipj=sscalelip(fracinbuf)
1733          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1734         elseif (zj.gt.bufliptop) then
1735          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1736          sslipj=sscalelip(fracinbuf)
1737          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1738         else
1739          sslipj=1.0d0
1740          ssgradlipj=0.0
1741         endif
1742        else
1743          sslipj=0.0d0
1744          ssgradlipj=0.0
1745        endif
1746       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1747        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1748       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1749        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1750 !------------------------------------------------
1751       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1752       xj_safe=xj
1753       yj_safe=yj
1754       zj_safe=zj
1755       subchap=0
1756       do xshift=-1,1
1757       do yshift=-1,1
1758       do zshift=-1,1
1759           xj=xj_safe+xshift*boxxsize
1760           yj=yj_safe+yshift*boxysize
1761           zj=zj_safe+zshift*boxzsize
1762           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1763           if(dist_temp.lt.dist_init) then
1764             dist_init=dist_temp
1765             xj_temp=xj
1766             yj_temp=yj
1767             zj_temp=zj
1768             subchap=1
1769           endif
1770        enddo
1771        enddo
1772        enddo
1773        if (subchap.eq.1) then
1774           xj=xj_temp-xi
1775           yj=yj_temp-yi
1776           zj=zj_temp-zi
1777        else
1778           xj=xj_safe-xi
1779           yj=yj_safe-yi
1780           zj=zj_safe-zi
1781        endif
1782             dxj=dc_norm(1,nres+j)
1783             dyj=dc_norm(2,nres+j)
1784             dzj=dc_norm(3,nres+j)
1785 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1786 !            write (iout,*) "j",j," dc_norm",& !d
1787 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1788 !          write(iout,*)"rrij ",rrij
1789 !          write(iout,*)"xj yj zj ", xj, yj, zj
1790 !          write(iout,*)"xi yi zi ", xi, yi, zi
1791 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1792             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1793             rij=dsqrt(rrij)
1794             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1795             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1796 !            print *,sss_ele_cut,sss_ele_grad,&
1797 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1798             if (sss_ele_cut.le.0.0) cycle
1799 ! Calculate angle-dependent terms of energy and contributions to their
1800 ! derivatives.
1801             call sc_angular
1802             sigsq=1.0D0/sigsq
1803             sig=sig0ij*dsqrt(sigsq)
1804             rij_shift=1.0D0/rij-sig+sig0ij
1805 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1806 !            "sig0ij",sig0ij
1807 ! for diagnostics; uncomment
1808 !            rij_shift=1.2*sig0ij
1809 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1810             if (rij_shift.le.0.0D0) then
1811               evdw=1.0D20
1812 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1813 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1814 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1815               return
1816             endif
1817             sigder=-sig*sigsq
1818 !---------------------------------------------------------------
1819             rij_shift=1.0D0/rij_shift
1820             fac=rij_shift**expon
1821             faclip=fac
1822             e1=fac*fac*aa!(itypi,itypj)
1823             e2=fac*bb!(itypi,itypj)
1824             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1825             eps2der=evdwij*eps3rt
1826             eps3der=evdwij*eps2rt
1827 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1828 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1829 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1830             evdwij=evdwij*eps2rt*eps3rt
1831             evdw=evdw+evdwij*sss_ele_cut
1832             if (lprn) then
1833             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1834             epsi=bb**2/aa!(itypi,itypj)
1835             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1836               restyp(itypi,1),i,restyp(itypj,1),j, &
1837               epsi,sigm,chi1,chi2,chip1,chip2, &
1838               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1839               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1840               evdwij
1841             endif
1842
1843             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1844                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1845 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1846 !            if (energy_dec) write (iout,*) &
1847 !                             'evdw',i,j,evdwij
1848 !                       print *,"ZALAMKA", evdw
1849
1850 ! Calculate gradient components.
1851             e1=e1*eps1*eps2rt**2*eps3rt**2
1852             fac=-expon*(e1+evdwij)*rij_shift
1853             sigder=fac*sigder
1854             fac=rij*fac
1855 !            print *,'before fac',fac,rij,evdwij
1856             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1857             /sigma(itypi,itypj)*rij
1858 !            print *,'grad part scale',fac,   &
1859 !             evdwij*sss_ele_grad/sss_ele_cut &
1860 !            /sigma(itypi,itypj)*rij
1861 !            fac=0.0d0
1862 ! Calculate the radial part of the gradient
1863             gg(1)=xj*fac
1864             gg(2)=yj*fac
1865             gg(3)=zj*fac
1866 !C Calculate the radial part of the gradient
1867             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1868        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1869         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1870        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1871             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1872             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1873
1874 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1875 ! Calculate angular part of the gradient.
1876             call sc_grad
1877             ENDIF    ! dyn_ss
1878           enddo      ! j
1879         enddo        ! iint
1880       enddo          ! i
1881 !       print *,"ZALAMKA", evdw
1882 !      write (iout,*) "Number of loop steps in EGB:",ind
1883 !ccc      energy_dec=.false.
1884       return
1885       end subroutine egb
1886 !-----------------------------------------------------------------------------
1887       subroutine egbv(evdw)
1888 !
1889 ! This subroutine calculates the interaction energy of nonbonded side chains
1890 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1891 !
1892       use comm_srutu
1893       use calc_data
1894 !      implicit real*8 (a-h,o-z)
1895 !      include 'DIMENSIONS'
1896 !      include 'COMMON.GEO'
1897 !      include 'COMMON.VAR'
1898 !      include 'COMMON.LOCAL'
1899 !      include 'COMMON.CHAIN'
1900 !      include 'COMMON.DERIV'
1901 !      include 'COMMON.NAMES'
1902 !      include 'COMMON.INTERACT'
1903 !      include 'COMMON.IOUNITS'
1904 !      include 'COMMON.CALC'
1905       use comm_srutu
1906 !el      integer :: icall
1907 !el      common /srutu/ icall
1908       logical :: lprn
1909 !el local variables
1910       integer :: iint,itypi,itypi1,itypj
1911       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1912       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1913
1914 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1915       evdw=0.0D0
1916       lprn=.false.
1917 !     if (icall.eq.0) lprn=.true.
1918 !el      ind=0
1919       do i=iatsc_s,iatsc_e
1920         itypi=iabs(itype(i,1))
1921         if (itypi.eq.ntyp1) cycle
1922         itypi1=iabs(itype(i+1,1))
1923         xi=c(1,nres+i)
1924         yi=c(2,nres+i)
1925         zi=c(3,nres+i)
1926         dxi=dc_norm(1,nres+i)
1927         dyi=dc_norm(2,nres+i)
1928         dzi=dc_norm(3,nres+i)
1929 !        dsci_inv=dsc_inv(itypi)
1930         dsci_inv=vbld_inv(i+nres)
1931 !
1932 ! Calculate SC interaction energy.
1933 !
1934         do iint=1,nint_gr(i)
1935           do j=istart(i,iint),iend(i,iint)
1936 !el            ind=ind+1
1937             itypj=iabs(itype(j,1))
1938             if (itypj.eq.ntyp1) cycle
1939 !            dscj_inv=dsc_inv(itypj)
1940             dscj_inv=vbld_inv(j+nres)
1941             sig0ij=sigma(itypi,itypj)
1942             r0ij=r0(itypi,itypj)
1943             chi1=chi(itypi,itypj)
1944             chi2=chi(itypj,itypi)
1945             chi12=chi1*chi2
1946             chip1=chip(itypi)
1947             chip2=chip(itypj)
1948             chip12=chip1*chip2
1949             alf1=alp(itypi)
1950             alf2=alp(itypj)
1951             alf12=0.5D0*(alf1+alf2)
1952 ! For diagnostics only!!!
1953 !           chi1=0.0D0
1954 !           chi2=0.0D0
1955 !           chi12=0.0D0
1956 !           chip1=0.0D0
1957 !           chip2=0.0D0
1958 !           chip12=0.0D0
1959 !           alf1=0.0D0
1960 !           alf2=0.0D0
1961 !           alf12=0.0D0
1962             xj=c(1,nres+j)-xi
1963             yj=c(2,nres+j)-yi
1964             zj=c(3,nres+j)-zi
1965             dxj=dc_norm(1,nres+j)
1966             dyj=dc_norm(2,nres+j)
1967             dzj=dc_norm(3,nres+j)
1968             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1969             rij=dsqrt(rrij)
1970 ! Calculate angle-dependent terms of energy and contributions to their
1971 ! derivatives.
1972             call sc_angular
1973             sigsq=1.0D0/sigsq
1974             sig=sig0ij*dsqrt(sigsq)
1975             rij_shift=1.0D0/rij-sig+r0ij
1976 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1977             if (rij_shift.le.0.0D0) then
1978               evdw=1.0D20
1979               return
1980             endif
1981             sigder=-sig*sigsq
1982 !---------------------------------------------------------------
1983             rij_shift=1.0D0/rij_shift
1984             fac=rij_shift**expon
1985             e1=fac*fac*aa_aq(itypi,itypj)
1986             e2=fac*bb_aq(itypi,itypj)
1987             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1988             eps2der=evdwij*eps3rt
1989             eps3der=evdwij*eps2rt
1990             fac_augm=rrij**expon
1991             e_augm=augm(itypi,itypj)*fac_augm
1992             evdwij=evdwij*eps2rt*eps3rt
1993             evdw=evdw+evdwij+e_augm
1994             if (lprn) then
1995             sigm=dabs(aa_aq(itypi,itypj)/&
1996             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1997             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1998             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1999               restyp(itypi,1),i,restyp(itypj,1),j,&
2000               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2001               chi1,chi2,chip1,chip2,&
2002               eps1,eps2rt**2,eps3rt**2,&
2003               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2004               evdwij+e_augm
2005             endif
2006 ! Calculate gradient components.
2007             e1=e1*eps1*eps2rt**2*eps3rt**2
2008             fac=-expon*(e1+evdwij)*rij_shift
2009             sigder=fac*sigder
2010             fac=rij*fac-2*expon*rrij*e_augm
2011 ! Calculate the radial part of the gradient
2012             gg(1)=xj*fac
2013             gg(2)=yj*fac
2014             gg(3)=zj*fac
2015 ! Calculate angular part of the gradient.
2016             call sc_grad
2017           enddo      ! j
2018         enddo        ! iint
2019       enddo          ! i
2020       end subroutine egbv
2021 !-----------------------------------------------------------------------------
2022 !el      subroutine sc_angular in module geometry
2023 !-----------------------------------------------------------------------------
2024       subroutine e_softsphere(evdw)
2025 !
2026 ! This subroutine calculates the interaction energy of nonbonded side chains
2027 ! assuming the LJ potential of interaction.
2028 !
2029 !      implicit real*8 (a-h,o-z)
2030 !      include 'DIMENSIONS'
2031       real(kind=8),parameter :: accur=1.0d-10
2032 !      include 'COMMON.GEO'
2033 !      include 'COMMON.VAR'
2034 !      include 'COMMON.LOCAL'
2035 !      include 'COMMON.CHAIN'
2036 !      include 'COMMON.DERIV'
2037 !      include 'COMMON.INTERACT'
2038 !      include 'COMMON.TORSION'
2039 !      include 'COMMON.SBRIDGE'
2040 !      include 'COMMON.NAMES'
2041 !      include 'COMMON.IOUNITS'
2042 !      include 'COMMON.CONTACTS'
2043       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2044 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2045 !el local variables
2046       integer :: i,iint,j,itypi,itypi1,itypj,k
2047       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2048       real(kind=8) :: fac
2049
2050       evdw=0.0D0
2051       do i=iatsc_s,iatsc_e
2052         itypi=iabs(itype(i,1))
2053         if (itypi.eq.ntyp1) cycle
2054         itypi1=iabs(itype(i+1,1))
2055         xi=c(1,nres+i)
2056         yi=c(2,nres+i)
2057         zi=c(3,nres+i)
2058 !
2059 ! Calculate SC interaction energy.
2060 !
2061         do iint=1,nint_gr(i)
2062 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2063 !d   &                  'iend=',iend(i,iint)
2064           do j=istart(i,iint),iend(i,iint)
2065             itypj=iabs(itype(j,1))
2066             if (itypj.eq.ntyp1) cycle
2067             xj=c(1,nres+j)-xi
2068             yj=c(2,nres+j)-yi
2069             zj=c(3,nres+j)-zi
2070             rij=xj*xj+yj*yj+zj*zj
2071 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2072             r0ij=r0(itypi,itypj)
2073             r0ijsq=r0ij*r0ij
2074 !            print *,i,j,r0ij,dsqrt(rij)
2075             if (rij.lt.r0ijsq) then
2076               evdwij=0.25d0*(rij-r0ijsq)**2
2077               fac=rij-r0ijsq
2078             else
2079               evdwij=0.0d0
2080               fac=0.0d0
2081             endif
2082             evdw=evdw+evdwij
2083 !
2084 ! Calculate the components of the gradient in DC and X
2085 !
2086             gg(1)=xj*fac
2087             gg(2)=yj*fac
2088             gg(3)=zj*fac
2089             do k=1,3
2090               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2091               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2092               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2093               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2094             enddo
2095 !grad            do k=i,j-1
2096 !grad              do l=1,3
2097 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2098 !grad              enddo
2099 !grad            enddo
2100           enddo ! j
2101         enddo ! iint
2102       enddo ! i
2103       return
2104       end subroutine e_softsphere
2105 !-----------------------------------------------------------------------------
2106       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2107 !
2108 ! Soft-sphere potential of p-p interaction
2109 !
2110 !      implicit real*8 (a-h,o-z)
2111 !      include 'DIMENSIONS'
2112 !      include 'COMMON.CONTROL'
2113 !      include 'COMMON.IOUNITS'
2114 !      include 'COMMON.GEO'
2115 !      include 'COMMON.VAR'
2116 !      include 'COMMON.LOCAL'
2117 !      include 'COMMON.CHAIN'
2118 !      include 'COMMON.DERIV'
2119 !      include 'COMMON.INTERACT'
2120 !      include 'COMMON.CONTACTS'
2121 !      include 'COMMON.TORSION'
2122 !      include 'COMMON.VECTORS'
2123 !      include 'COMMON.FFIELD'
2124       real(kind=8),dimension(3) :: ggg
2125 !d      write(iout,*) 'In EELEC_soft_sphere'
2126 !el local variables
2127       integer :: i,j,k,num_conti,iteli,itelj
2128       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2129       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2130       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2131
2132       ees=0.0D0
2133       evdw1=0.0D0
2134       eel_loc=0.0d0
2135       eello_turn3=0.0d0
2136       eello_turn4=0.0d0
2137 !el      ind=0
2138       do i=iatel_s,iatel_e
2139         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2140         dxi=dc(1,i)
2141         dyi=dc(2,i)
2142         dzi=dc(3,i)
2143         xmedi=c(1,i)+0.5d0*dxi
2144         ymedi=c(2,i)+0.5d0*dyi
2145         zmedi=c(3,i)+0.5d0*dzi
2146         num_conti=0
2147 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2148         do j=ielstart(i),ielend(i)
2149           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2150 !el          ind=ind+1
2151           iteli=itel(i)
2152           itelj=itel(j)
2153           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2154           r0ij=rpp(iteli,itelj)
2155           r0ijsq=r0ij*r0ij
2156           dxj=dc(1,j)
2157           dyj=dc(2,j)
2158           dzj=dc(3,j)
2159           xj=c(1,j)+0.5D0*dxj-xmedi
2160           yj=c(2,j)+0.5D0*dyj-ymedi
2161           zj=c(3,j)+0.5D0*dzj-zmedi
2162           rij=xj*xj+yj*yj+zj*zj
2163           if (rij.lt.r0ijsq) then
2164             evdw1ij=0.25d0*(rij-r0ijsq)**2
2165             fac=rij-r0ijsq
2166           else
2167             evdw1ij=0.0d0
2168             fac=0.0d0
2169           endif
2170           evdw1=evdw1+evdw1ij
2171 !
2172 ! Calculate contributions to the Cartesian gradient.
2173 !
2174           ggg(1)=fac*xj
2175           ggg(2)=fac*yj
2176           ggg(3)=fac*zj
2177           do k=1,3
2178             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2179             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2180           enddo
2181 !
2182 ! Loop over residues i+1 thru j-1.
2183 !
2184 !grad          do k=i+1,j-1
2185 !grad            do l=1,3
2186 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2187 !grad            enddo
2188 !grad          enddo
2189         enddo ! j
2190       enddo   ! i
2191 !grad      do i=nnt,nct-1
2192 !grad        do k=1,3
2193 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2194 !grad        enddo
2195 !grad        do j=i+1,nct-1
2196 !grad          do k=1,3
2197 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2198 !grad          enddo
2199 !grad        enddo
2200 !grad      enddo
2201       return
2202       end subroutine eelec_soft_sphere
2203 !-----------------------------------------------------------------------------
2204       subroutine vec_and_deriv
2205 !      implicit real*8 (a-h,o-z)
2206 !      include 'DIMENSIONS'
2207 #ifdef MPI
2208       include 'mpif.h'
2209 #endif
2210 !      include 'COMMON.IOUNITS'
2211 !      include 'COMMON.GEO'
2212 !      include 'COMMON.VAR'
2213 !      include 'COMMON.LOCAL'
2214 !      include 'COMMON.CHAIN'
2215 !      include 'COMMON.VECTORS'
2216 !      include 'COMMON.SETUP'
2217 !      include 'COMMON.TIME1'
2218       real(kind=8),dimension(3,3,2) :: uyder,uzder
2219       real(kind=8),dimension(2) :: vbld_inv_temp
2220 ! Compute the local reference systems. For reference system (i), the
2221 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2222 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2223 !el local variables
2224       integer :: i,j,k,l
2225       real(kind=8) :: facy,fac,costh
2226
2227 #ifdef PARVEC
2228       do i=ivec_start,ivec_end
2229 #else
2230       do i=1,nres-1
2231 #endif
2232           if (i.eq.nres-1) then
2233 ! Case of the last full residue
2234 ! Compute the Z-axis
2235             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2236             costh=dcos(pi-theta(nres))
2237             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2238             do k=1,3
2239               uz(k,i)=fac*uz(k,i)
2240             enddo
2241 ! Compute the derivatives of uz
2242             uzder(1,1,1)= 0.0d0
2243             uzder(2,1,1)=-dc_norm(3,i-1)
2244             uzder(3,1,1)= dc_norm(2,i-1)
2245             uzder(1,2,1)= dc_norm(3,i-1)
2246             uzder(2,2,1)= 0.0d0
2247             uzder(3,2,1)=-dc_norm(1,i-1)
2248             uzder(1,3,1)=-dc_norm(2,i-1)
2249             uzder(2,3,1)= dc_norm(1,i-1)
2250             uzder(3,3,1)= 0.0d0
2251             uzder(1,1,2)= 0.0d0
2252             uzder(2,1,2)= dc_norm(3,i)
2253             uzder(3,1,2)=-dc_norm(2,i)
2254             uzder(1,2,2)=-dc_norm(3,i)
2255             uzder(2,2,2)= 0.0d0
2256             uzder(3,2,2)= dc_norm(1,i)
2257             uzder(1,3,2)= dc_norm(2,i)
2258             uzder(2,3,2)=-dc_norm(1,i)
2259             uzder(3,3,2)= 0.0d0
2260 ! Compute the Y-axis
2261             facy=fac
2262             do k=1,3
2263               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2264             enddo
2265 ! Compute the derivatives of uy
2266             do j=1,3
2267               do k=1,3
2268                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2269                               -dc_norm(k,i)*dc_norm(j,i-1)
2270                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2271               enddo
2272               uyder(j,j,1)=uyder(j,j,1)-costh
2273               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2274             enddo
2275             do j=1,2
2276               do k=1,3
2277                 do l=1,3
2278                   uygrad(l,k,j,i)=uyder(l,k,j)
2279                   uzgrad(l,k,j,i)=uzder(l,k,j)
2280                 enddo
2281               enddo
2282             enddo
2283             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2284             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2285             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2286             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2287           else
2288 ! Other residues
2289 ! Compute the Z-axis
2290             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2291             costh=dcos(pi-theta(i+2))
2292             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2293             do k=1,3
2294               uz(k,i)=fac*uz(k,i)
2295             enddo
2296 ! Compute the derivatives of uz
2297             uzder(1,1,1)= 0.0d0
2298             uzder(2,1,1)=-dc_norm(3,i+1)
2299             uzder(3,1,1)= dc_norm(2,i+1)
2300             uzder(1,2,1)= dc_norm(3,i+1)
2301             uzder(2,2,1)= 0.0d0
2302             uzder(3,2,1)=-dc_norm(1,i+1)
2303             uzder(1,3,1)=-dc_norm(2,i+1)
2304             uzder(2,3,1)= dc_norm(1,i+1)
2305             uzder(3,3,1)= 0.0d0
2306             uzder(1,1,2)= 0.0d0
2307             uzder(2,1,2)= dc_norm(3,i)
2308             uzder(3,1,2)=-dc_norm(2,i)
2309             uzder(1,2,2)=-dc_norm(3,i)
2310             uzder(2,2,2)= 0.0d0
2311             uzder(3,2,2)= dc_norm(1,i)
2312             uzder(1,3,2)= dc_norm(2,i)
2313             uzder(2,3,2)=-dc_norm(1,i)
2314             uzder(3,3,2)= 0.0d0
2315 ! Compute the Y-axis
2316             facy=fac
2317             do k=1,3
2318               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2319             enddo
2320 ! Compute the derivatives of uy
2321             do j=1,3
2322               do k=1,3
2323                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2324                               -dc_norm(k,i)*dc_norm(j,i+1)
2325                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2326               enddo
2327               uyder(j,j,1)=uyder(j,j,1)-costh
2328               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2329             enddo
2330             do j=1,2
2331               do k=1,3
2332                 do l=1,3
2333                   uygrad(l,k,j,i)=uyder(l,k,j)
2334                   uzgrad(l,k,j,i)=uzder(l,k,j)
2335                 enddo
2336               enddo
2337             enddo
2338             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2339             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2340             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2341             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2342           endif
2343       enddo
2344       do i=1,nres-1
2345         vbld_inv_temp(1)=vbld_inv(i+1)
2346         if (i.lt.nres-1) then
2347           vbld_inv_temp(2)=vbld_inv(i+2)
2348           else
2349           vbld_inv_temp(2)=vbld_inv(i)
2350           endif
2351         do j=1,2
2352           do k=1,3
2353             do l=1,3
2354               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2355               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2356             enddo
2357           enddo
2358         enddo
2359       enddo
2360 #if defined(PARVEC) && defined(MPI)
2361       if (nfgtasks1.gt.1) then
2362         time00=MPI_Wtime()
2363 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2364 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2365 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2366         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2367          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2368          FG_COMM1,IERR)
2369         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2370          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2371          FG_COMM1,IERR)
2372         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2373          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2374          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2375         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2376          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2377          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2378         time_gather=time_gather+MPI_Wtime()-time00
2379       endif
2380 !      if (fg_rank.eq.0) then
2381 !        write (iout,*) "Arrays UY and UZ"
2382 !        do i=1,nres-1
2383 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2384 !     &     (uz(k,i),k=1,3)
2385 !        enddo
2386 !      endif
2387 #endif
2388       return
2389       end subroutine vec_and_deriv
2390 !-----------------------------------------------------------------------------
2391       subroutine check_vecgrad
2392 !      implicit real*8 (a-h,o-z)
2393 !      include 'DIMENSIONS'
2394 !      include 'COMMON.IOUNITS'
2395 !      include 'COMMON.GEO'
2396 !      include 'COMMON.VAR'
2397 !      include 'COMMON.LOCAL'
2398 !      include 'COMMON.CHAIN'
2399 !      include 'COMMON.VECTORS'
2400       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2401       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2402       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2403       real(kind=8),dimension(3) :: erij
2404       real(kind=8) :: delta=1.0d-7
2405 !el local variables
2406       integer :: i,j,k,l
2407
2408       call vec_and_deriv
2409 !d      do i=1,nres
2410 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2411 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2412 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2413 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2414 !d     &     (dc_norm(if90,i),if90=1,3)
2415 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2416 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2417 !d          write(iout,'(a)')
2418 !d      enddo
2419       do i=1,nres
2420         do j=1,2
2421           do k=1,3
2422             do l=1,3
2423               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2424               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2425             enddo
2426           enddo
2427         enddo
2428       enddo
2429       call vec_and_deriv
2430       do i=1,nres
2431         do j=1,3
2432           uyt(j,i)=uy(j,i)
2433           uzt(j,i)=uz(j,i)
2434         enddo
2435       enddo
2436       do i=1,nres
2437 !d        write (iout,*) 'i=',i
2438         do k=1,3
2439           erij(k)=dc_norm(k,i)
2440         enddo
2441         do j=1,3
2442           do k=1,3
2443             dc_norm(k,i)=erij(k)
2444           enddo
2445           dc_norm(j,i)=dc_norm(j,i)+delta
2446 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2447 !          do k=1,3
2448 !            dc_norm(k,i)=dc_norm(k,i)/fac
2449 !          enddo
2450 !          write (iout,*) (dc_norm(k,i),k=1,3)
2451 !          write (iout,*) (erij(k),k=1,3)
2452           call vec_and_deriv
2453           do k=1,3
2454             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2455             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2456             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2457             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2458           enddo
2459 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2460 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2461 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2462         enddo
2463         do k=1,3
2464           dc_norm(k,i)=erij(k)
2465         enddo
2466 !d        do k=1,3
2467 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2468 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2469 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2470 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2471 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2472 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2473 !d          write (iout,'(a)')
2474 !d        enddo
2475       enddo
2476       return
2477       end subroutine check_vecgrad
2478 !-----------------------------------------------------------------------------
2479       subroutine set_matrices
2480 !      implicit real*8 (a-h,o-z)
2481 !      include 'DIMENSIONS'
2482 #ifdef MPI
2483       include "mpif.h"
2484 !      include "COMMON.SETUP"
2485       integer :: IERR
2486       integer :: status(MPI_STATUS_SIZE)
2487 #endif
2488 !      include 'COMMON.IOUNITS'
2489 !      include 'COMMON.GEO'
2490 !      include 'COMMON.VAR'
2491 !      include 'COMMON.LOCAL'
2492 !      include 'COMMON.CHAIN'
2493 !      include 'COMMON.DERIV'
2494 !      include 'COMMON.INTERACT'
2495 !      include 'COMMON.CONTACTS'
2496 !      include 'COMMON.TORSION'
2497 !      include 'COMMON.VECTORS'
2498 !      include 'COMMON.FFIELD'
2499       real(kind=8) :: auxvec(2),auxmat(2,2)
2500       integer :: i,iti1,iti,k,l
2501       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2502 !       print *,"in set matrices"
2503 !
2504 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2505 ! to calculate the el-loc multibody terms of various order.
2506 !
2507 !AL el      mu=0.0d0
2508 #ifdef PARMAT
2509       do i=ivec_start+2,ivec_end+2
2510 #else
2511       do i=3,nres+1
2512 #endif
2513 !      print *,i,"i"
2514         if (i .lt. nres+1) then
2515           sin1=dsin(phi(i))
2516           cos1=dcos(phi(i))
2517           sintab(i-2)=sin1
2518           costab(i-2)=cos1
2519           obrot(1,i-2)=cos1
2520           obrot(2,i-2)=sin1
2521           sin2=dsin(2*phi(i))
2522           cos2=dcos(2*phi(i))
2523           sintab2(i-2)=sin2
2524           costab2(i-2)=cos2
2525           obrot2(1,i-2)=cos2
2526           obrot2(2,i-2)=sin2
2527           Ug(1,1,i-2)=-cos1
2528           Ug(1,2,i-2)=-sin1
2529           Ug(2,1,i-2)=-sin1
2530           Ug(2,2,i-2)= cos1
2531           Ug2(1,1,i-2)=-cos2
2532           Ug2(1,2,i-2)=-sin2
2533           Ug2(2,1,i-2)=-sin2
2534           Ug2(2,2,i-2)= cos2
2535         else
2536           costab(i-2)=1.0d0
2537           sintab(i-2)=0.0d0
2538           obrot(1,i-2)=1.0d0
2539           obrot(2,i-2)=0.0d0
2540           obrot2(1,i-2)=0.0d0
2541           obrot2(2,i-2)=0.0d0
2542           Ug(1,1,i-2)=1.0d0
2543           Ug(1,2,i-2)=0.0d0
2544           Ug(2,1,i-2)=0.0d0
2545           Ug(2,2,i-2)=1.0d0
2546           Ug2(1,1,i-2)=0.0d0
2547           Ug2(1,2,i-2)=0.0d0
2548           Ug2(2,1,i-2)=0.0d0
2549           Ug2(2,2,i-2)=0.0d0
2550         endif
2551         if (i .gt. 3 .and. i .lt. nres+1) then
2552           obrot_der(1,i-2)=-sin1
2553           obrot_der(2,i-2)= cos1
2554           Ugder(1,1,i-2)= sin1
2555           Ugder(1,2,i-2)=-cos1
2556           Ugder(2,1,i-2)=-cos1
2557           Ugder(2,2,i-2)=-sin1
2558           dwacos2=cos2+cos2
2559           dwasin2=sin2+sin2
2560           obrot2_der(1,i-2)=-dwasin2
2561           obrot2_der(2,i-2)= dwacos2
2562           Ug2der(1,1,i-2)= dwasin2
2563           Ug2der(1,2,i-2)=-dwacos2
2564           Ug2der(2,1,i-2)=-dwacos2
2565           Ug2der(2,2,i-2)=-dwasin2
2566         else
2567           obrot_der(1,i-2)=0.0d0
2568           obrot_der(2,i-2)=0.0d0
2569           Ugder(1,1,i-2)=0.0d0
2570           Ugder(1,2,i-2)=0.0d0
2571           Ugder(2,1,i-2)=0.0d0
2572           Ugder(2,2,i-2)=0.0d0
2573           obrot2_der(1,i-2)=0.0d0
2574           obrot2_der(2,i-2)=0.0d0
2575           Ug2der(1,1,i-2)=0.0d0
2576           Ug2der(1,2,i-2)=0.0d0
2577           Ug2der(2,1,i-2)=0.0d0
2578           Ug2der(2,2,i-2)=0.0d0
2579         endif
2580 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2581         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2582            if (itype(i-2,1).eq.0) then
2583           iti=ntortyp+1
2584            else
2585           iti = itortyp(itype(i-2,1))
2586            endif
2587         else
2588           iti=ntortyp+1
2589         endif
2590 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2591         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2592            if (itype(i-1,1).eq.0) then
2593           iti1=ntortyp+1
2594            else
2595           iti1 = itortyp(itype(i-1,1))
2596            endif
2597         else
2598           iti1=ntortyp+1
2599         endif
2600 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2601 !d        write (iout,*) '*******i',i,' iti1',iti
2602 !d        write (iout,*) 'b1',b1(:,iti)
2603 !d        write (iout,*) 'b2',b2(:,iti)
2604 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2605 !        if (i .gt. iatel_s+2) then
2606         if (i .gt. nnt+2) then
2607           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2608           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2609           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2610           then
2611           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2612           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2613           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2614           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2615           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2616           endif
2617         else
2618           do k=1,2
2619             Ub2(k,i-2)=0.0d0
2620             Ctobr(k,i-2)=0.0d0
2621             Dtobr2(k,i-2)=0.0d0
2622             do l=1,2
2623               EUg(l,k,i-2)=0.0d0
2624               CUg(l,k,i-2)=0.0d0
2625               DUg(l,k,i-2)=0.0d0
2626               DtUg2(l,k,i-2)=0.0d0
2627             enddo
2628           enddo
2629         endif
2630         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2631         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2632         do k=1,2
2633           muder(k,i-2)=Ub2der(k,i-2)
2634         enddo
2635 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2636         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2637           if (itype(i-1,1).eq.0) then
2638            iti1=ntortyp+1
2639           elseif (itype(i-1,1).le.ntyp) then
2640             iti1 = itortyp(itype(i-1,1))
2641           else
2642             iti1=ntortyp+1
2643           endif
2644         else
2645           iti1=ntortyp+1
2646         endif
2647         do k=1,2
2648           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2649         enddo
2650 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2651 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2652 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2653 !d        write (iout,*) 'mu1',mu1(:,i-2)
2654 !d        write (iout,*) 'mu2',mu2(:,i-2)
2655         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2656         then
2657         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2658         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2659         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2660         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2661         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2662 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2663         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2664         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2665         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2666         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2667         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2668         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2669         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2670         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2671         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2672         endif
2673       enddo
2674 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2675 ! The order of matrices is from left to right.
2676       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2677       then
2678 !      do i=max0(ivec_start,2),ivec_end
2679       do i=2,nres-1
2680         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2681         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2682         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2683         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2684         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2685         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2686         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2687         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2688       enddo
2689       endif
2690 #if defined(MPI) && defined(PARMAT)
2691 #ifdef DEBUG
2692 !      if (fg_rank.eq.0) then
2693         write (iout,*) "Arrays UG and UGDER before GATHER"
2694         do i=1,nres-1
2695           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2696            ((ug(l,k,i),l=1,2),k=1,2),&
2697            ((ugder(l,k,i),l=1,2),k=1,2)
2698         enddo
2699         write (iout,*) "Arrays UG2 and UG2DER"
2700         do i=1,nres-1
2701           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2702            ((ug2(l,k,i),l=1,2),k=1,2),&
2703            ((ug2der(l,k,i),l=1,2),k=1,2)
2704         enddo
2705         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2706         do i=1,nres-1
2707           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2708            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2709            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2710         enddo
2711         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2712         do i=1,nres-1
2713           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2714            costab(i),sintab(i),costab2(i),sintab2(i)
2715         enddo
2716         write (iout,*) "Array MUDER"
2717         do i=1,nres-1
2718           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2719         enddo
2720 !      endif
2721 #endif
2722       if (nfgtasks.gt.1) then
2723         time00=MPI_Wtime()
2724 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2725 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2726 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2727 #ifdef MATGATHER
2728         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2729          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2730          FG_COMM1,IERR)
2731         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2732          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2733          FG_COMM1,IERR)
2734         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2735          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2736          FG_COMM1,IERR)
2737         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2738          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2739          FG_COMM1,IERR)
2740         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2741          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2742          FG_COMM1,IERR)
2743         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2744          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2745          FG_COMM1,IERR)
2746         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2747          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2748          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2749         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2750          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2751          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2752         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2753          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2754          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2755         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2756          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2757          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2758         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2759         then
2760         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2761          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2762          FG_COMM1,IERR)
2763         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2764          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2765          FG_COMM1,IERR)
2766         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2767          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2768          FG_COMM1,IERR)
2769        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2770          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2771          FG_COMM1,IERR)
2772         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2773          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2774          FG_COMM1,IERR)
2775         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2776          ivec_count(fg_rank1),&
2777          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2778          FG_COMM1,IERR)
2779         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2780          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2781          FG_COMM1,IERR)
2782         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2783          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2784          FG_COMM1,IERR)
2785         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2786          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2787          FG_COMM1,IERR)
2788         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2789          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2790          FG_COMM1,IERR)
2791         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2792          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2793          FG_COMM1,IERR)
2794         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2795          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2796          FG_COMM1,IERR)
2797         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2798          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2799          FG_COMM1,IERR)
2800         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2801          ivec_count(fg_rank1),&
2802          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2803          FG_COMM1,IERR)
2804         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2805          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2806          FG_COMM1,IERR)
2807        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2808          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2809          FG_COMM1,IERR)
2810         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2811          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2812          FG_COMM1,IERR)
2813        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2814          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2815          FG_COMM1,IERR)
2816         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2817          ivec_count(fg_rank1),&
2818          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2819          FG_COMM1,IERR)
2820         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2821          ivec_count(fg_rank1),&
2822          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2823          FG_COMM1,IERR)
2824         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2825          ivec_count(fg_rank1),&
2826          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2827          MPI_MAT2,FG_COMM1,IERR)
2828         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2829          ivec_count(fg_rank1),&
2830          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2831          MPI_MAT2,FG_COMM1,IERR)
2832         endif
2833 #else
2834 ! Passes matrix info through the ring
2835       isend=fg_rank1
2836       irecv=fg_rank1-1
2837       if (irecv.lt.0) irecv=nfgtasks1-1
2838       iprev=irecv
2839       inext=fg_rank1+1
2840       if (inext.ge.nfgtasks1) inext=0
2841       do i=1,nfgtasks1-1
2842 !        write (iout,*) "isend",isend," irecv",irecv
2843 !        call flush(iout)
2844         lensend=lentyp(isend)
2845         lenrecv=lentyp(irecv)
2846 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2847 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2848 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2849 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2850 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2851 !        write (iout,*) "Gather ROTAT1"
2852 !        call flush(iout)
2853 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2854 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2855 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2856 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2857 !        write (iout,*) "Gather ROTAT2"
2858 !        call flush(iout)
2859         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2860          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2861          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2862          iprev,4400+irecv,FG_COMM,status,IERR)
2863 !        write (iout,*) "Gather ROTAT_OLD"
2864 !        call flush(iout)
2865         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2866          MPI_PRECOMP11(lensend),inext,5500+isend,&
2867          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2868          iprev,5500+irecv,FG_COMM,status,IERR)
2869 !        write (iout,*) "Gather PRECOMP11"
2870 !        call flush(iout)
2871         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2872          MPI_PRECOMP12(lensend),inext,6600+isend,&
2873          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2874          iprev,6600+irecv,FG_COMM,status,IERR)
2875 !        write (iout,*) "Gather PRECOMP12"
2876 !        call flush(iout)
2877         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2878         then
2879         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2880          MPI_ROTAT2(lensend),inext,7700+isend,&
2881          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2882          iprev,7700+irecv,FG_COMM,status,IERR)
2883 !        write (iout,*) "Gather PRECOMP21"
2884 !        call flush(iout)
2885         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2886          MPI_PRECOMP22(lensend),inext,8800+isend,&
2887          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2888          iprev,8800+irecv,FG_COMM,status,IERR)
2889 !        write (iout,*) "Gather PRECOMP22"
2890 !        call flush(iout)
2891         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2892          MPI_PRECOMP23(lensend),inext,9900+isend,&
2893          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2894          MPI_PRECOMP23(lenrecv),&
2895          iprev,9900+irecv,FG_COMM,status,IERR)
2896 !        write (iout,*) "Gather PRECOMP23"
2897 !        call flush(iout)
2898         endif
2899         isend=irecv
2900         irecv=irecv-1
2901         if (irecv.lt.0) irecv=nfgtasks1-1
2902       enddo
2903 #endif
2904         time_gather=time_gather+MPI_Wtime()-time00
2905       endif
2906 #ifdef DEBUG
2907 !      if (fg_rank.eq.0) then
2908         write (iout,*) "Arrays UG and UGDER"
2909         do i=1,nres-1
2910           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2911            ((ug(l,k,i),l=1,2),k=1,2),&
2912            ((ugder(l,k,i),l=1,2),k=1,2)
2913         enddo
2914         write (iout,*) "Arrays UG2 and UG2DER"
2915         do i=1,nres-1
2916           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2917            ((ug2(l,k,i),l=1,2),k=1,2),&
2918            ((ug2der(l,k,i),l=1,2),k=1,2)
2919         enddo
2920         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2921         do i=1,nres-1
2922           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2923            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2924            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2925         enddo
2926         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2927         do i=1,nres-1
2928           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2929            costab(i),sintab(i),costab2(i),sintab2(i)
2930         enddo
2931         write (iout,*) "Array MUDER"
2932         do i=1,nres-1
2933           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2934         enddo
2935 !      endif
2936 #endif
2937 #endif
2938 !d      do i=1,nres
2939 !d        iti = itortyp(itype(i,1))
2940 !d        write (iout,*) i
2941 !d        do j=1,2
2942 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2943 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2944 !d        enddo
2945 !d      enddo
2946       return
2947       end subroutine set_matrices
2948 !-----------------------------------------------------------------------------
2949       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2950 !
2951 ! This subroutine calculates the average interaction energy and its gradient
2952 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2953 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2954 ! The potential depends both on the distance of peptide-group centers and on
2955 ! the orientation of the CA-CA virtual bonds.
2956 !
2957       use comm_locel
2958 !      implicit real*8 (a-h,o-z)
2959 #ifdef MPI
2960       include 'mpif.h'
2961 #endif
2962 !      include 'DIMENSIONS'
2963 !      include 'COMMON.CONTROL'
2964 !      include 'COMMON.SETUP'
2965 !      include 'COMMON.IOUNITS'
2966 !      include 'COMMON.GEO'
2967 !      include 'COMMON.VAR'
2968 !      include 'COMMON.LOCAL'
2969 !      include 'COMMON.CHAIN'
2970 !      include 'COMMON.DERIV'
2971 !      include 'COMMON.INTERACT'
2972 !      include 'COMMON.CONTACTS'
2973 !      include 'COMMON.TORSION'
2974 !      include 'COMMON.VECTORS'
2975 !      include 'COMMON.FFIELD'
2976 !      include 'COMMON.TIME1'
2977       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2978       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2979       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2980 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2981       real(kind=8),dimension(4) :: muij
2982 !el      integer :: num_conti,j1,j2
2983 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2984 !el        dz_normi,xmedi,ymedi,zmedi
2985
2986 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2987 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2988 !el          num_conti,j1,j2
2989
2990 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2991 #ifdef MOMENT
2992       real(kind=8) :: scal_el=1.0d0
2993 #else
2994       real(kind=8) :: scal_el=0.5d0
2995 #endif
2996 ! 12/13/98
2997 ! 13-go grudnia roku pamietnego...
2998       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2999                                              0.0d0,1.0d0,0.0d0,&
3000                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3001 !el local variables
3002       integer :: i,k,j
3003       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3004       real(kind=8) :: fac,t_eelecij,fracinbuf
3005
3006
3007 !d      write(iout,*) 'In EELEC'
3008 !        print *,"IN EELEC"
3009 !d      do i=1,nloctyp
3010 !d        write(iout,*) 'Type',i
3011 !d        write(iout,*) 'B1',B1(:,i)
3012 !d        write(iout,*) 'B2',B2(:,i)
3013 !d        write(iout,*) 'CC',CC(:,:,i)
3014 !d        write(iout,*) 'DD',DD(:,:,i)
3015 !d        write(iout,*) 'EE',EE(:,:,i)
3016 !d      enddo
3017 !d      call check_vecgrad
3018 !d      stop
3019 !      ees=0.0d0  !AS
3020 !      evdw1=0.0d0
3021 !      eel_loc=0.0d0
3022 !      eello_turn3=0.0d0
3023 !      eello_turn4=0.0d0
3024       t_eelecij=0.0d0
3025       ees=0.0D0
3026       evdw1=0.0D0
3027       eel_loc=0.0d0
3028       eello_turn3=0.0d0
3029       eello_turn4=0.0d0
3030 !
3031
3032       if (icheckgrad.eq.1) then
3033 !el
3034 !        do i=0,2*nres+2
3035 !          dc_norm(1,i)=0.0d0
3036 !          dc_norm(2,i)=0.0d0
3037 !          dc_norm(3,i)=0.0d0
3038 !        enddo
3039         do i=1,nres-1
3040           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3041           do k=1,3
3042             dc_norm(k,i)=dc(k,i)*fac
3043           enddo
3044 !          write (iout,*) 'i',i,' fac',fac
3045         enddo
3046       endif
3047 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3048 !        wturn6
3049       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3050           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3051           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3052 !        call vec_and_deriv
3053 #ifdef TIMING
3054         time01=MPI_Wtime()
3055 #endif
3056 !        print *, "before set matrices"
3057         call set_matrices
3058 !        print *, "after set matrices"
3059
3060 #ifdef TIMING
3061         time_mat=time_mat+MPI_Wtime()-time01
3062 #endif
3063       endif
3064 !       print *, "after set matrices"
3065 !d      do i=1,nres-1
3066 !d        write (iout,*) 'i=',i
3067 !d        do k=1,3
3068 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3069 !d        enddo
3070 !d        do k=1,3
3071 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3072 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3073 !d        enddo
3074 !d      enddo
3075       t_eelecij=0.0d0
3076       ees=0.0D0
3077       evdw1=0.0D0
3078       eel_loc=0.0d0
3079       eello_turn3=0.0d0
3080       eello_turn4=0.0d0
3081 !el      ind=0
3082       do i=1,nres
3083         num_cont_hb(i)=0
3084       enddo
3085 !d      print '(a)','Enter EELEC'
3086 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3087 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3088 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3089       do i=1,nres
3090         gel_loc_loc(i)=0.0d0
3091         gcorr_loc(i)=0.0d0
3092       enddo
3093 !
3094 !
3095 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3096 !
3097 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3098 !
3099
3100
3101 !        print *,"before iturn3 loop"
3102       do i=iturn3_start,iturn3_end
3103         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3104         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3105         dxi=dc(1,i)
3106         dyi=dc(2,i)
3107         dzi=dc(3,i)
3108         dx_normi=dc_norm(1,i)
3109         dy_normi=dc_norm(2,i)
3110         dz_normi=dc_norm(3,i)
3111         xmedi=c(1,i)+0.5d0*dxi
3112         ymedi=c(2,i)+0.5d0*dyi
3113         zmedi=c(3,i)+0.5d0*dzi
3114           xmedi=dmod(xmedi,boxxsize)
3115           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3116           ymedi=dmod(ymedi,boxysize)
3117           if (ymedi.lt.0) ymedi=ymedi+boxysize
3118           zmedi=dmod(zmedi,boxzsize)
3119           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3120         num_conti=0
3121        if ((zmedi.gt.bordlipbot) &
3122         .and.(zmedi.lt.bordliptop)) then
3123 !C the energy transfer exist
3124         if (zmedi.lt.buflipbot) then
3125 !C what fraction I am in
3126          fracinbuf=1.0d0- &
3127                ((zmedi-bordlipbot)/lipbufthick)
3128 !C lipbufthick is thickenes of lipid buffore
3129          sslipi=sscalelip(fracinbuf)
3130          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3131         elseif (zmedi.gt.bufliptop) then
3132          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3133          sslipi=sscalelip(fracinbuf)
3134          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3135         else
3136          sslipi=1.0d0
3137          ssgradlipi=0.0
3138         endif
3139        else
3140          sslipi=0.0d0
3141          ssgradlipi=0.0
3142        endif
3143 !       print *,i,sslipi,ssgradlipi
3144        call eelecij(i,i+2,ees,evdw1,eel_loc)
3145         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3146         num_cont_hb(i)=num_conti
3147       enddo
3148       do i=iturn4_start,iturn4_end
3149         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3150           .or. itype(i+3,1).eq.ntyp1 &
3151           .or. itype(i+4,1).eq.ntyp1) cycle
3152         dxi=dc(1,i)
3153         dyi=dc(2,i)
3154         dzi=dc(3,i)
3155         dx_normi=dc_norm(1,i)
3156         dy_normi=dc_norm(2,i)
3157         dz_normi=dc_norm(3,i)
3158         xmedi=c(1,i)+0.5d0*dxi
3159         ymedi=c(2,i)+0.5d0*dyi
3160         zmedi=c(3,i)+0.5d0*dzi
3161           xmedi=dmod(xmedi,boxxsize)
3162           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3163           ymedi=dmod(ymedi,boxysize)
3164           if (ymedi.lt.0) ymedi=ymedi+boxysize
3165           zmedi=dmod(zmedi,boxzsize)
3166           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3167        if ((zmedi.gt.bordlipbot)  &
3168        .and.(zmedi.lt.bordliptop)) then
3169 !C the energy transfer exist
3170         if (zmedi.lt.buflipbot) then
3171 !C what fraction I am in
3172          fracinbuf=1.0d0- &
3173              ((zmedi-bordlipbot)/lipbufthick)
3174 !C lipbufthick is thickenes of lipid buffore
3175          sslipi=sscalelip(fracinbuf)
3176          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3177         elseif (zmedi.gt.bufliptop) then
3178          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3179          sslipi=sscalelip(fracinbuf)
3180          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3181         else
3182          sslipi=1.0d0
3183          ssgradlipi=0.0
3184         endif
3185        else
3186          sslipi=0.0d0
3187          ssgradlipi=0.0
3188        endif
3189
3190         num_conti=num_cont_hb(i)
3191         call eelecij(i,i+3,ees,evdw1,eel_loc)
3192         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3193          call eturn4(i,eello_turn4)
3194         num_cont_hb(i)=num_conti
3195       enddo   ! i
3196 !
3197 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3198 !
3199 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3200       do i=iatel_s,iatel_e
3201         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3202         dxi=dc(1,i)
3203         dyi=dc(2,i)
3204         dzi=dc(3,i)
3205         dx_normi=dc_norm(1,i)
3206         dy_normi=dc_norm(2,i)
3207         dz_normi=dc_norm(3,i)
3208         xmedi=c(1,i)+0.5d0*dxi
3209         ymedi=c(2,i)+0.5d0*dyi
3210         zmedi=c(3,i)+0.5d0*dzi
3211           xmedi=dmod(xmedi,boxxsize)
3212           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3213           ymedi=dmod(ymedi,boxysize)
3214           if (ymedi.lt.0) ymedi=ymedi+boxysize
3215           zmedi=dmod(zmedi,boxzsize)
3216           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3217        if ((zmedi.gt.bordlipbot)  &
3218         .and.(zmedi.lt.bordliptop)) then
3219 !C the energy transfer exist
3220         if (zmedi.lt.buflipbot) then
3221 !C what fraction I am in
3222          fracinbuf=1.0d0- &
3223              ((zmedi-bordlipbot)/lipbufthick)
3224 !C lipbufthick is thickenes of lipid buffore
3225          sslipi=sscalelip(fracinbuf)
3226          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3227         elseif (zmedi.gt.bufliptop) then
3228          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3229          sslipi=sscalelip(fracinbuf)
3230          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3231         else
3232          sslipi=1.0d0
3233          ssgradlipi=0.0
3234         endif
3235        else
3236          sslipi=0.0d0
3237          ssgradlipi=0.0
3238        endif
3239
3240 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3241         num_conti=num_cont_hb(i)
3242         do j=ielstart(i),ielend(i)
3243 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3244           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3245           call eelecij(i,j,ees,evdw1,eel_loc)
3246         enddo ! j
3247         num_cont_hb(i)=num_conti
3248       enddo   ! i
3249 !      write (iout,*) "Number of loop steps in EELEC:",ind
3250 !d      do i=1,nres
3251 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3252 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3253 !d      enddo
3254 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3255 !cc      eel_loc=eel_loc+eello_turn3
3256 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3257       return
3258       end subroutine eelec
3259 !-----------------------------------------------------------------------------
3260       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3261
3262       use comm_locel
3263 !      implicit real*8 (a-h,o-z)
3264 !      include 'DIMENSIONS'
3265 #ifdef MPI
3266       include "mpif.h"
3267 #endif
3268 !      include 'COMMON.CONTROL'
3269 !      include 'COMMON.IOUNITS'
3270 !      include 'COMMON.GEO'
3271 !      include 'COMMON.VAR'
3272 !      include 'COMMON.LOCAL'
3273 !      include 'COMMON.CHAIN'
3274 !      include 'COMMON.DERIV'
3275 !      include 'COMMON.INTERACT'
3276 !      include 'COMMON.CONTACTS'
3277 !      include 'COMMON.TORSION'
3278 !      include 'COMMON.VECTORS'
3279 !      include 'COMMON.FFIELD'
3280 !      include 'COMMON.TIME1'
3281       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3282       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3283       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3284 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3285       real(kind=8),dimension(4) :: muij
3286       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3287                     dist_temp, dist_init,rlocshield,fracinbuf
3288       integer xshift,yshift,zshift,ilist,iresshield
3289 !el      integer :: num_conti,j1,j2
3290 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3291 !el        dz_normi,xmedi,ymedi,zmedi
3292
3293 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3294 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3295 !el          num_conti,j1,j2
3296
3297 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3298 #ifdef MOMENT
3299       real(kind=8) :: scal_el=1.0d0
3300 #else
3301       real(kind=8) :: scal_el=0.5d0
3302 #endif
3303 ! 12/13/98
3304 ! 13-go grudnia roku pamietnego...
3305       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3306                                              0.0d0,1.0d0,0.0d0,&
3307                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3308 !      integer :: maxconts=nres/4
3309 !el local variables
3310       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3311       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3312       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3313       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3314                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3315                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3316                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3317                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3318                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3319                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3320                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3321 !      maxconts=nres/4
3322 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3323 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3324
3325 !          time00=MPI_Wtime()
3326 !d      write (iout,*) "eelecij",i,j
3327 !          ind=ind+1
3328           iteli=itel(i)
3329           itelj=itel(j)
3330           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3331           aaa=app(iteli,itelj)
3332           bbb=bpp(iteli,itelj)
3333           ael6i=ael6(iteli,itelj)
3334           ael3i=ael3(iteli,itelj)
3335           dxj=dc(1,j)
3336           dyj=dc(2,j)
3337           dzj=dc(3,j)
3338           dx_normj=dc_norm(1,j)
3339           dy_normj=dc_norm(2,j)
3340           dz_normj=dc_norm(3,j)
3341 !          xj=c(1,j)+0.5D0*dxj-xmedi
3342 !          yj=c(2,j)+0.5D0*dyj-ymedi
3343 !          zj=c(3,j)+0.5D0*dzj-zmedi
3344           xj=c(1,j)+0.5D0*dxj
3345           yj=c(2,j)+0.5D0*dyj
3346           zj=c(3,j)+0.5D0*dzj
3347           xj=mod(xj,boxxsize)
3348           if (xj.lt.0) xj=xj+boxxsize
3349           yj=mod(yj,boxysize)
3350           if (yj.lt.0) yj=yj+boxysize
3351           zj=mod(zj,boxzsize)
3352           if (zj.lt.0) zj=zj+boxzsize
3353        if ((zj.gt.bordlipbot)  &
3354        .and.(zj.lt.bordliptop)) then
3355 !C the energy transfer exist
3356         if (zj.lt.buflipbot) then
3357 !C what fraction I am in
3358          fracinbuf=1.0d0-     &
3359              ((zj-bordlipbot)/lipbufthick)
3360 !C lipbufthick is thickenes of lipid buffore
3361          sslipj=sscalelip(fracinbuf)
3362          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3363         elseif (zj.gt.bufliptop) then
3364          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3365          sslipj=sscalelip(fracinbuf)
3366          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3367         else
3368          sslipj=1.0d0
3369          ssgradlipj=0.0
3370         endif
3371        else
3372          sslipj=0.0d0
3373          ssgradlipj=0.0
3374        endif
3375
3376       isubchap=0
3377       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3378       xj_safe=xj
3379       yj_safe=yj
3380       zj_safe=zj
3381       do xshift=-1,1
3382       do yshift=-1,1
3383       do zshift=-1,1
3384           xj=xj_safe+xshift*boxxsize
3385           yj=yj_safe+yshift*boxysize
3386           zj=zj_safe+zshift*boxzsize
3387           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3388           if(dist_temp.lt.dist_init) then
3389             dist_init=dist_temp
3390             xj_temp=xj
3391             yj_temp=yj
3392             zj_temp=zj
3393             isubchap=1
3394           endif
3395        enddo
3396        enddo
3397        enddo
3398        if (isubchap.eq.1) then
3399 !C          print *,i,j
3400           xj=xj_temp-xmedi
3401           yj=yj_temp-ymedi
3402           zj=zj_temp-zmedi
3403        else
3404           xj=xj_safe-xmedi
3405           yj=yj_safe-ymedi
3406           zj=zj_safe-zmedi
3407        endif
3408
3409           rij=xj*xj+yj*yj+zj*zj
3410           rrmij=1.0D0/rij
3411           rij=dsqrt(rij)
3412 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3413             sss_ele_cut=sscale_ele(rij)
3414             sss_ele_grad=sscagrad_ele(rij)
3415 !             sss_ele_cut=1.0d0
3416 !             sss_ele_grad=0.0d0
3417 !            print *,sss_ele_cut,sss_ele_grad,&
3418 !            (rij),r_cut_ele,rlamb_ele
3419 !            if (sss_ele_cut.le.0.0) go to 128
3420
3421           rmij=1.0D0/rij
3422           r3ij=rrmij*rmij
3423           r6ij=r3ij*r3ij
3424           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3425           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3426           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3427           fac=cosa-3.0D0*cosb*cosg
3428           ev1=aaa*r6ij*r6ij
3429 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3430           if (j.eq.i+2) ev1=scal_el*ev1
3431           ev2=bbb*r6ij
3432           fac3=ael6i*r6ij
3433           fac4=ael3i*r3ij
3434           evdwij=ev1+ev2
3435           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3436           el2=fac4*fac
3437 !          eesij=el1+el2
3438           if (shield_mode.gt.0) then
3439 !C          fac_shield(i)=0.4
3440 !C          fac_shield(j)=0.6
3441           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3442           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3443           eesij=(el1+el2)
3444           ees=ees+eesij*sss_ele_cut
3445 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3446 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3447           else
3448           fac_shield(i)=1.0
3449           fac_shield(j)=1.0
3450           eesij=(el1+el2)
3451           ees=ees+eesij   &
3452             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3453 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3454           endif
3455
3456 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3457           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3458 !          ees=ees+eesij*sss_ele_cut
3459           evdw1=evdw1+evdwij*sss_ele_cut  &
3460            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3461 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3462 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3463 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3464 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3465
3466           if (energy_dec) then
3467 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3468 !                  'evdw1',i,j,evdwij,&
3469 !                  iteli,itelj,aaa,evdw1
3470               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3471               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3472           endif
3473 !
3474 ! Calculate contributions to the Cartesian gradient.
3475 !
3476 #ifdef SPLITELE
3477           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3478               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3479           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3480              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3481           fac1=fac
3482           erij(1)=xj*rmij
3483           erij(2)=yj*rmij
3484           erij(3)=zj*rmij
3485 !
3486 ! Radial derivatives. First process both termini of the fragment (i,j)
3487 !
3488           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3489           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3490           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3491            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3492           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3493             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3494
3495           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3496           (shield_mode.gt.0)) then
3497 !C          print *,i,j
3498           do ilist=1,ishield_list(i)
3499            iresshield=shield_list(ilist,i)
3500            do k=1,3
3501            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3502            *2.0*sss_ele_cut
3503            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3504                    rlocshield &
3505             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3506             *sss_ele_cut
3507             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3508            enddo
3509           enddo
3510           do ilist=1,ishield_list(j)
3511            iresshield=shield_list(ilist,j)
3512            do k=1,3
3513            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3514           *2.0*sss_ele_cut
3515            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3516                    rlocshield &
3517            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3518            *sss_ele_cut
3519            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3520            enddo
3521           enddo
3522           do k=1,3
3523             gshieldc(k,i)=gshieldc(k,i)+ &
3524                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3525            *sss_ele_cut
3526
3527             gshieldc(k,j)=gshieldc(k,j)+ &
3528                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3529            *sss_ele_cut
3530
3531             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3532                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3533            *sss_ele_cut
3534
3535             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3536                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3537            *sss_ele_cut
3538
3539            enddo
3540            endif
3541
3542
3543 !          do k=1,3
3544 !            ghalf=0.5D0*ggg(k)
3545 !            gelc(k,i)=gelc(k,i)+ghalf
3546 !            gelc(k,j)=gelc(k,j)+ghalf
3547 !          enddo
3548 ! 9/28/08 AL Gradient compotents will be summed only at the end
3549           do k=1,3
3550             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3551             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3552           enddo
3553             gelc_long(3,j)=gelc_long(3,j)+  &
3554           ssgradlipj*eesij/2.0d0*lipscale**2&
3555            *sss_ele_cut
3556
3557             gelc_long(3,i)=gelc_long(3,i)+  &
3558           ssgradlipi*eesij/2.0d0*lipscale**2&
3559            *sss_ele_cut
3560
3561
3562 !
3563 ! Loop over residues i+1 thru j-1.
3564 !
3565 !grad          do k=i+1,j-1
3566 !grad            do l=1,3
3567 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3568 !grad            enddo
3569 !grad          enddo
3570           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3571            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3572           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3573            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3574           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3575            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3576
3577 !          do k=1,3
3578 !            ghalf=0.5D0*ggg(k)
3579 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3580 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3581 !          enddo
3582 ! 9/28/08 AL Gradient compotents will be summed only at the end
3583           do k=1,3
3584             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3585             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3586           enddo
3587
3588 !C Lipidic part for scaling weight
3589            gvdwpp(3,j)=gvdwpp(3,j)+ &
3590           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3591            gvdwpp(3,i)=gvdwpp(3,i)+ &
3592           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3593 !! Loop over residues i+1 thru j-1.
3594 !
3595 !grad          do k=i+1,j-1
3596 !grad            do l=1,3
3597 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3598 !grad            enddo
3599 !grad          enddo
3600 #else
3601           facvdw=(ev1+evdwij)*sss_ele_cut &
3602            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3603
3604           facel=(el1+eesij)*sss_ele_cut
3605           fac1=fac
3606           fac=-3*rrmij*(facvdw+facvdw+facel)
3607           erij(1)=xj*rmij
3608           erij(2)=yj*rmij
3609           erij(3)=zj*rmij
3610 !
3611 ! Radial derivatives. First process both termini of the fragment (i,j)
3612 !
3613           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3614           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3615           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3616 !          do k=1,3
3617 !            ghalf=0.5D0*ggg(k)
3618 !            gelc(k,i)=gelc(k,i)+ghalf
3619 !            gelc(k,j)=gelc(k,j)+ghalf
3620 !          enddo
3621 ! 9/28/08 AL Gradient compotents will be summed only at the end
3622           do k=1,3
3623             gelc_long(k,j)=gelc(k,j)+ggg(k)
3624             gelc_long(k,i)=gelc(k,i)-ggg(k)
3625           enddo
3626 !
3627 ! Loop over residues i+1 thru j-1.
3628 !
3629 !grad          do k=i+1,j-1
3630 !grad            do l=1,3
3631 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3632 !grad            enddo
3633 !grad          enddo
3634 ! 9/28/08 AL Gradient compotents will be summed only at the end
3635           ggg(1)=facvdw*xj &
3636            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3637           ggg(2)=facvdw*yj &
3638            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3639           ggg(3)=facvdw*zj &
3640            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3641
3642           do k=1,3
3643             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3644             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3645           enddo
3646            gvdwpp(3,j)=gvdwpp(3,j)+ &
3647           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3648            gvdwpp(3,i)=gvdwpp(3,i)+ &
3649           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3650
3651 #endif
3652 !
3653 ! Angular part
3654 !
3655           ecosa=2.0D0*fac3*fac1+fac4
3656           fac4=-3.0D0*fac4
3657           fac3=-6.0D0*fac3
3658           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3659           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3660           do k=1,3
3661             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3662             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3663           enddo
3664 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3665 !d   &          (dcosg(k),k=1,3)
3666           do k=1,3
3667             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3668              *fac_shield(i)**2*fac_shield(j)**2 &
3669              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3670
3671           enddo
3672 !          do k=1,3
3673 !            ghalf=0.5D0*ggg(k)
3674 !            gelc(k,i)=gelc(k,i)+ghalf
3675 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3676 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3677 !            gelc(k,j)=gelc(k,j)+ghalf
3678 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3679 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3680 !          enddo
3681 !grad          do k=i+1,j-1
3682 !grad            do l=1,3
3683 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3684 !grad            enddo
3685 !grad          enddo
3686           do k=1,3
3687             gelc(k,i)=gelc(k,i) &
3688                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3689                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3690                      *sss_ele_cut &
3691                      *fac_shield(i)**2*fac_shield(j)**2 &
3692                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3693
3694             gelc(k,j)=gelc(k,j) &
3695                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3696                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3697                      *sss_ele_cut  &
3698                      *fac_shield(i)**2*fac_shield(j)**2  &
3699                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3700
3701             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3702             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3703           enddo
3704
3705           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3706               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3707               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3708 !
3709 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3710 !   energy of a peptide unit is assumed in the form of a second-order
3711 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3712 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3713 !   are computed for EVERY pair of non-contiguous peptide groups.
3714 !
3715           if (j.lt.nres-1) then
3716             j1=j+1
3717             j2=j-1
3718           else
3719             j1=j-1
3720             j2=j-2
3721           endif
3722           kkk=0
3723           do k=1,2
3724             do l=1,2
3725               kkk=kkk+1
3726               muij(kkk)=mu(k,i)*mu(l,j)
3727             enddo
3728           enddo
3729 !d         write (iout,*) 'EELEC: i',i,' j',j
3730 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3731 !d          write(iout,*) 'muij',muij
3732           ury=scalar(uy(1,i),erij)
3733           urz=scalar(uz(1,i),erij)
3734           vry=scalar(uy(1,j),erij)
3735           vrz=scalar(uz(1,j),erij)
3736           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3737           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3738           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3739           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3740           fac=dsqrt(-ael6i)*r3ij
3741           a22=a22*fac
3742           a23=a23*fac
3743           a32=a32*fac
3744           a33=a33*fac
3745 !d          write (iout,'(4i5,4f10.5)')
3746 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3747 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3748 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3749 !d     &      uy(:,j),uz(:,j)
3750 !d          write (iout,'(4f10.5)')
3751 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3752 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3753 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3754 !d           write (iout,'(9f10.5/)')
3755 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3756 ! Derivatives of the elements of A in virtual-bond vectors
3757           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3758           do k=1,3
3759             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3760             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3761             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3762             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3763             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3764             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3765             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3766             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3767             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3768             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3769             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3770             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3771           enddo
3772 ! Compute radial contributions to the gradient
3773           facr=-3.0d0*rrmij
3774           a22der=a22*facr
3775           a23der=a23*facr
3776           a32der=a32*facr
3777           a33der=a33*facr
3778           agg(1,1)=a22der*xj
3779           agg(2,1)=a22der*yj
3780           agg(3,1)=a22der*zj
3781           agg(1,2)=a23der*xj
3782           agg(2,2)=a23der*yj
3783           agg(3,2)=a23der*zj
3784           agg(1,3)=a32der*xj
3785           agg(2,3)=a32der*yj
3786           agg(3,3)=a32der*zj
3787           agg(1,4)=a33der*xj
3788           agg(2,4)=a33der*yj
3789           agg(3,4)=a33der*zj
3790 ! Add the contributions coming from er
3791           fac3=-3.0d0*fac
3792           do k=1,3
3793             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3794             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3795             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3796             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3797           enddo
3798           do k=1,3
3799 ! Derivatives in DC(i)
3800 !grad            ghalf1=0.5d0*agg(k,1)
3801 !grad            ghalf2=0.5d0*agg(k,2)
3802 !grad            ghalf3=0.5d0*agg(k,3)
3803 !grad            ghalf4=0.5d0*agg(k,4)
3804             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3805             -3.0d0*uryg(k,2)*vry)!+ghalf1
3806             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3807             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3808             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3809             -3.0d0*urzg(k,2)*vry)!+ghalf3
3810             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3811             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3812 ! Derivatives in DC(i+1)
3813             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3814             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3815             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3816             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3817             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3818             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3819             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3820             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3821 ! Derivatives in DC(j)
3822             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3823             -3.0d0*vryg(k,2)*ury)!+ghalf1
3824             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3825             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3826             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3827             -3.0d0*vryg(k,2)*urz)!+ghalf3
3828             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3829             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3830 ! Derivatives in DC(j+1) or DC(nres-1)
3831             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3832             -3.0d0*vryg(k,3)*ury)
3833             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3834             -3.0d0*vrzg(k,3)*ury)
3835             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3836             -3.0d0*vryg(k,3)*urz)
3837             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3838             -3.0d0*vrzg(k,3)*urz)
3839 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3840 !grad              do l=1,4
3841 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3842 !grad              enddo
3843 !grad            endif
3844           enddo
3845           acipa(1,1)=a22
3846           acipa(1,2)=a23
3847           acipa(2,1)=a32
3848           acipa(2,2)=a33
3849           a22=-a22
3850           a23=-a23
3851           do l=1,2
3852             do k=1,3
3853               agg(k,l)=-agg(k,l)
3854               aggi(k,l)=-aggi(k,l)
3855               aggi1(k,l)=-aggi1(k,l)
3856               aggj(k,l)=-aggj(k,l)
3857               aggj1(k,l)=-aggj1(k,l)
3858             enddo
3859           enddo
3860           if (j.lt.nres-1) then
3861             a22=-a22
3862             a32=-a32
3863             do l=1,3,2
3864               do k=1,3
3865                 agg(k,l)=-agg(k,l)
3866                 aggi(k,l)=-aggi(k,l)
3867                 aggi1(k,l)=-aggi1(k,l)
3868                 aggj(k,l)=-aggj(k,l)
3869                 aggj1(k,l)=-aggj1(k,l)
3870               enddo
3871             enddo
3872           else
3873             a22=-a22
3874             a23=-a23
3875             a32=-a32
3876             a33=-a33
3877             do l=1,4
3878               do k=1,3
3879                 agg(k,l)=-agg(k,l)
3880                 aggi(k,l)=-aggi(k,l)
3881                 aggi1(k,l)=-aggi1(k,l)
3882                 aggj(k,l)=-aggj(k,l)
3883                 aggj1(k,l)=-aggj1(k,l)
3884               enddo
3885             enddo
3886           endif
3887           ENDIF ! WCORR
3888           IF (wel_loc.gt.0.0d0) THEN
3889 ! Contribution to the local-electrostatic energy coming from the i-j pair
3890           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3891            +a33*muij(4)
3892           if (shield_mode.eq.0) then
3893            fac_shield(i)=1.0
3894            fac_shield(j)=1.0
3895           endif
3896           eel_loc_ij=eel_loc_ij &
3897          *fac_shield(i)*fac_shield(j) &
3898          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3899 !C Now derivative over eel_loc
3900           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3901          (shield_mode.gt.0)) then
3902 !C          print *,i,j
3903
3904           do ilist=1,ishield_list(i)
3905            iresshield=shield_list(ilist,i)
3906            do k=1,3
3907            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3908                                                 /fac_shield(i)&
3909            *sss_ele_cut
3910            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3911                    rlocshield  &
3912           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3913           *sss_ele_cut
3914
3915             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3916            +rlocshield
3917            enddo
3918           enddo
3919           do ilist=1,ishield_list(j)
3920            iresshield=shield_list(ilist,j)
3921            do k=1,3
3922            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3923                                             /fac_shield(j)   &
3924             *sss_ele_cut
3925            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3926                    rlocshield  &
3927       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3928        *sss_ele_cut
3929
3930            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3931                   +rlocshield
3932
3933            enddo
3934           enddo
3935
3936           do k=1,3
3937             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3938                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3939                     *sss_ele_cut
3940             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3941                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3942                     *sss_ele_cut
3943             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3944                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3945                     *sss_ele_cut
3946             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3947                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3948                     *sss_ele_cut
3949
3950            enddo
3951            endif
3952
3953
3954 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3955 !           eel_loc_ij=0.0
3956           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3957                   'eelloc',i,j,eel_loc_ij
3958 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3959 !          if (energy_dec) write (iout,*) "muij",muij
3960 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3961
3962           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3963 ! Partial derivatives in virtual-bond dihedral angles gamma
3964           if (i.gt.1) &
3965           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3966                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3967                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3968                  *sss_ele_cut  &
3969           *fac_shield(i)*fac_shield(j) &
3970           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3971
3972           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3973                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3974                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3975                  *sss_ele_cut &
3976           *fac_shield(i)*fac_shield(j) &
3977           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3978 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3979 !          do l=1,3
3980 !            ggg(1)=(agg(1,1)*muij(1)+ &
3981 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3982 !            *sss_ele_cut &
3983 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3984 !            ggg(2)=(agg(2,1)*muij(1)+ &
3985 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3986 !            *sss_ele_cut &
3987 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3988 !            ggg(3)=(agg(3,1)*muij(1)+ &
3989 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3990 !            *sss_ele_cut &
3991 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3992            xtemp(1)=xj
3993            xtemp(2)=yj
3994            xtemp(3)=zj
3995
3996            do l=1,3
3997             ggg(l)=(agg(l,1)*muij(1)+ &
3998                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3999             *sss_ele_cut &
4000           *fac_shield(i)*fac_shield(j) &
4001           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4002              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4003
4004
4005             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4006             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4007 !grad            ghalf=0.5d0*ggg(l)
4008 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4009 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4010           enddo
4011             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4012           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4013           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4014
4015             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4016           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4017           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4018
4019 !grad          do k=i+1,j2
4020 !grad            do l=1,3
4021 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4022 !grad            enddo
4023 !grad          enddo
4024 ! Remaining derivatives of eello
4025           do l=1,3
4026             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4027                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(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,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4034                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4035             +aggi1(l,4)*muij(4))&
4036             *sss_ele_cut &
4037           *fac_shield(i)*fac_shield(j) &
4038           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4039
4040 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4041             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4042                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(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             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4049                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4050             +aggj1(l,4)*muij(4))&
4051             *sss_ele_cut &
4052           *fac_shield(i)*fac_shield(j) &
4053           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4054
4055 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4056           enddo
4057           ENDIF
4058 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4059 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4060           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4061              .and. num_conti.le.maxconts) then
4062 !            write (iout,*) i,j," entered corr"
4063 !
4064 ! Calculate the contact function. The ith column of the array JCONT will
4065 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4066 ! greater than I). The arrays FACONT and GACONT will contain the values of
4067 ! the contact function and its derivative.
4068 !           r0ij=1.02D0*rpp(iteli,itelj)
4069 !           r0ij=1.11D0*rpp(iteli,itelj)
4070             r0ij=2.20D0*rpp(iteli,itelj)
4071 !           r0ij=1.55D0*rpp(iteli,itelj)
4072             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4073 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4074             if (fcont.gt.0.0D0) then
4075               num_conti=num_conti+1
4076               if (num_conti.gt.maxconts) then
4077 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4078 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4079                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4080                                ' will skip next contacts for this conf.', num_conti
4081               else
4082                 jcont_hb(num_conti,i)=j
4083 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4084 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4085                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4086                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4087 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4088 !  terms.
4089                 d_cont(num_conti,i)=rij
4090 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4091 !     --- Electrostatic-interaction matrix ---
4092                 a_chuj(1,1,num_conti,i)=a22
4093                 a_chuj(1,2,num_conti,i)=a23
4094                 a_chuj(2,1,num_conti,i)=a32
4095                 a_chuj(2,2,num_conti,i)=a33
4096 !     --- Gradient of rij
4097                 do kkk=1,3
4098                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4099                 enddo
4100                 kkll=0
4101                 do k=1,2
4102                   do l=1,2
4103                     kkll=kkll+1
4104                     do m=1,3
4105                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4106                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4107                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4108                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4109                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4110                     enddo
4111                   enddo
4112                 enddo
4113                 ENDIF
4114                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4115 ! Calculate contact energies
4116                 cosa4=4.0D0*cosa
4117                 wij=cosa-3.0D0*cosb*cosg
4118                 cosbg1=cosb+cosg
4119                 cosbg2=cosb-cosg
4120 !               fac3=dsqrt(-ael6i)/r0ij**3
4121                 fac3=dsqrt(-ael6i)*r3ij
4122 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4123                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4124                 if (ees0tmp.gt.0) then
4125                   ees0pij=dsqrt(ees0tmp)
4126                 else
4127                   ees0pij=0
4128                 endif
4129                 if (shield_mode.eq.0) then
4130                 fac_shield(i)=1.0d0
4131                 fac_shield(j)=1.0d0
4132                 else
4133                 ees0plist(num_conti,i)=j
4134                 endif
4135 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4136                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4137                 if (ees0tmp.gt.0) then
4138                   ees0mij=dsqrt(ees0tmp)
4139                 else
4140                   ees0mij=0
4141                 endif
4142 !               ees0mij=0.0D0
4143                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4144                      *sss_ele_cut &
4145                      *fac_shield(i)*fac_shield(j)
4146
4147                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4148                      *sss_ele_cut &
4149                      *fac_shield(i)*fac_shield(j)
4150
4151 ! Diagnostics. Comment out or remove after debugging!
4152 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4153 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4154 !               ees0m(num_conti,i)=0.0D0
4155 ! End diagnostics.
4156 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4157 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4158 ! Angular derivatives of the contact function
4159                 ees0pij1=fac3/ees0pij
4160                 ees0mij1=fac3/ees0mij
4161                 fac3p=-3.0D0*fac3*rrmij
4162                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4163                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4164 !               ees0mij1=0.0D0
4165                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4166                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4167                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4168                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4169                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4170                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4171                 ecosap=ecosa1+ecosa2
4172                 ecosbp=ecosb1+ecosb2
4173                 ecosgp=ecosg1+ecosg2
4174                 ecosam=ecosa1-ecosa2
4175                 ecosbm=ecosb1-ecosb2
4176                 ecosgm=ecosg1-ecosg2
4177 ! Diagnostics
4178 !               ecosap=ecosa1
4179 !               ecosbp=ecosb1
4180 !               ecosgp=ecosg1
4181 !               ecosam=0.0D0
4182 !               ecosbm=0.0D0
4183 !               ecosgm=0.0D0
4184 ! End diagnostics
4185                 facont_hb(num_conti,i)=fcont
4186                 fprimcont=fprimcont/rij
4187 !d              facont_hb(num_conti,i)=1.0D0
4188 ! Following line is for diagnostics.
4189 !d              fprimcont=0.0D0
4190                 do k=1,3
4191                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4192                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4193                 enddo
4194                 do k=1,3
4195                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4196                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4197                 enddo
4198                 gggp(1)=gggp(1)+ees0pijp*xj &
4199                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4200                 gggp(2)=gggp(2)+ees0pijp*yj &
4201                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4202                 gggp(3)=gggp(3)+ees0pijp*zj &
4203                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4204
4205                 gggm(1)=gggm(1)+ees0mijp*xj &
4206                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4207
4208                 gggm(2)=gggm(2)+ees0mijp*yj &
4209                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4210
4211                 gggm(3)=gggm(3)+ees0mijp*zj &
4212                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4213
4214 ! Derivatives due to the contact function
4215                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4216                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4217                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4218                 do k=1,3
4219 !
4220 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4221 !          following the change of gradient-summation algorithm.
4222 !
4223 !grad                  ghalfp=0.5D0*gggp(k)
4224 !grad                  ghalfm=0.5D0*gggm(k)
4225                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4226                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4227                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4228                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4229
4230                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4231                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4232                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4233                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4234
4235                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4236                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4237
4238                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4239                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4240                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4241                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4242
4243                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4244                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4245                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4246                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4247
4248                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4249                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4250
4251                 enddo
4252 ! Diagnostics. Comment out or remove after debugging!
4253 !diag           do k=1,3
4254 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4255 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4256 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4257 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4258 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4259 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4260 !diag           enddo
4261               ENDIF ! wcorr
4262               endif  ! num_conti.le.maxconts
4263             endif  ! fcont.gt.0
4264           endif    ! j.gt.i+1
4265           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4266             do k=1,4
4267               do l=1,3
4268                 ghalf=0.5d0*agg(l,k)
4269                 aggi(l,k)=aggi(l,k)+ghalf
4270                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4271                 aggj(l,k)=aggj(l,k)+ghalf
4272               enddo
4273             enddo
4274             if (j.eq.nres-1 .and. i.lt.j-2) then
4275               do k=1,4
4276                 do l=1,3
4277                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4278                 enddo
4279               enddo
4280             endif
4281           endif
4282  128  continue
4283 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4284       return
4285       end subroutine eelecij
4286 !-----------------------------------------------------------------------------
4287       subroutine eturn3(i,eello_turn3)
4288 ! Third- and fourth-order contributions from turns
4289
4290       use comm_locel
4291 !      implicit real*8 (a-h,o-z)
4292 !      include 'DIMENSIONS'
4293 !      include 'COMMON.IOUNITS'
4294 !      include 'COMMON.GEO'
4295 !      include 'COMMON.VAR'
4296 !      include 'COMMON.LOCAL'
4297 !      include 'COMMON.CHAIN'
4298 !      include 'COMMON.DERIV'
4299 !      include 'COMMON.INTERACT'
4300 !      include 'COMMON.CONTACTS'
4301 !      include 'COMMON.TORSION'
4302 !      include 'COMMON.VECTORS'
4303 !      include 'COMMON.FFIELD'
4304 !      include 'COMMON.CONTROL'
4305       real(kind=8),dimension(3) :: ggg
4306       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4307         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4308       real(kind=8),dimension(2) :: auxvec,auxvec1
4309 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4310       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4311 !el      integer :: num_conti,j1,j2
4312 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4313 !el        dz_normi,xmedi,ymedi,zmedi
4314
4315 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4316 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4317 !el         num_conti,j1,j2
4318 !el local variables
4319       integer :: i,j,l,k,ilist,iresshield
4320       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4321
4322       j=i+2
4323 !      write (iout,*) "eturn3",i,j,j1,j2
4324           zj=(c(3,j)+c(3,j+1))/2.0d0
4325           zj=mod(zj,boxzsize)
4326           if (zj.lt.0) zj=zj+boxzsize
4327           if ((zj.lt.0)) write (*,*) "CHUJ"
4328        if ((zj.gt.bordlipbot)  &
4329         .and.(zj.lt.bordliptop)) then
4330 !C the energy transfer exist
4331         if (zj.lt.buflipbot) then
4332 !C what fraction I am in
4333          fracinbuf=1.0d0-     &
4334              ((zj-bordlipbot)/lipbufthick)
4335 !C lipbufthick is thickenes of lipid buffore
4336          sslipj=sscalelip(fracinbuf)
4337          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4338         elseif (zj.gt.bufliptop) then
4339          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4340          sslipj=sscalelip(fracinbuf)
4341          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4342         else
4343          sslipj=1.0d0
4344          ssgradlipj=0.0
4345         endif
4346        else
4347          sslipj=0.0d0
4348          ssgradlipj=0.0
4349        endif
4350
4351       a_temp(1,1)=a22
4352       a_temp(1,2)=a23
4353       a_temp(2,1)=a32
4354       a_temp(2,2)=a33
4355 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4356 !
4357 !               Third-order contributions
4358 !
4359 !                 (i+2)o----(i+3)
4360 !                      | |
4361 !                      | |
4362 !                 (i+1)o----i
4363 !
4364 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4365 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4366         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4367         call transpose2(auxmat(1,1),auxmat1(1,1))
4368         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4369         if (shield_mode.eq.0) then
4370         fac_shield(i)=1.0d0
4371         fac_shield(j)=1.0d0
4372         endif
4373
4374         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4375          *fac_shield(i)*fac_shield(j)  &
4376          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4377         eello_t3= &
4378         0.5d0*(pizda(1,1)+pizda(2,2)) &
4379         *fac_shield(i)*fac_shield(j)
4380
4381         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4382                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4383           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4384        (shield_mode.gt.0)) then
4385 !C          print *,i,j
4386
4387           do ilist=1,ishield_list(i)
4388            iresshield=shield_list(ilist,i)
4389            do k=1,3
4390            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4391            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4392                    rlocshield &
4393            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4394             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4395              +rlocshield
4396            enddo
4397           enddo
4398           do ilist=1,ishield_list(j)
4399            iresshield=shield_list(ilist,j)
4400            do k=1,3
4401            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4402            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4403                    rlocshield &
4404            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4405            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4406                   +rlocshield
4407
4408            enddo
4409           enddo
4410
4411           do k=1,3
4412             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4413                    grad_shield(k,i)*eello_t3/fac_shield(i)
4414             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4415                    grad_shield(k,j)*eello_t3/fac_shield(j)
4416             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4417                    grad_shield(k,i)*eello_t3/fac_shield(i)
4418             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4419                    grad_shield(k,j)*eello_t3/fac_shield(j)
4420            enddo
4421            endif
4422
4423 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4424 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4425 !d     &    ' eello_turn3_num',4*eello_turn3_num
4426 ! Derivatives in gamma(i)
4427         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4428         call transpose2(auxmat2(1,1),auxmat3(1,1))
4429         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4430         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4431           *fac_shield(i)*fac_shield(j)        &
4432           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4433 ! Derivatives in gamma(i+1)
4434         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4435         call transpose2(auxmat2(1,1),auxmat3(1,1))
4436         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4437         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4438           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4439           *fac_shield(i)*fac_shield(j)        &
4440           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4441
4442 ! Cartesian derivatives
4443         do l=1,3
4444 !            ghalf1=0.5d0*agg(l,1)
4445 !            ghalf2=0.5d0*agg(l,2)
4446 !            ghalf3=0.5d0*agg(l,3)
4447 !            ghalf4=0.5d0*agg(l,4)
4448           a_temp(1,1)=aggi(l,1)!+ghalf1
4449           a_temp(1,2)=aggi(l,2)!+ghalf2
4450           a_temp(2,1)=aggi(l,3)!+ghalf3
4451           a_temp(2,2)=aggi(l,4)!+ghalf4
4452           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4453           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4454             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4455           *fac_shield(i)*fac_shield(j)      &
4456           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4457
4458           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4459           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4460           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4461           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4462           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4463           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4464             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4465           *fac_shield(i)*fac_shield(j)        &
4466           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4467
4468           a_temp(1,1)=aggj(l,1)!+ghalf1
4469           a_temp(1,2)=aggj(l,2)!+ghalf2
4470           a_temp(2,1)=aggj(l,3)!+ghalf3
4471           a_temp(2,2)=aggj(l,4)!+ghalf4
4472           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4473           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4474             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4475           *fac_shield(i)*fac_shield(j)      &
4476           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4477
4478           a_temp(1,1)=aggj1(l,1)
4479           a_temp(1,2)=aggj1(l,2)
4480           a_temp(2,1)=aggj1(l,3)
4481           a_temp(2,2)=aggj1(l,4)
4482           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4483           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4484             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4485           *fac_shield(i)*fac_shield(j)        &
4486           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4487         enddo
4488          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4489           ssgradlipi*eello_t3/4.0d0*lipscale
4490          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4491           ssgradlipj*eello_t3/4.0d0*lipscale
4492          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4493           ssgradlipi*eello_t3/4.0d0*lipscale
4494          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4495           ssgradlipj*eello_t3/4.0d0*lipscale
4496
4497       return
4498       end subroutine eturn3
4499 !-----------------------------------------------------------------------------
4500       subroutine eturn4(i,eello_turn4)
4501 ! Third- and fourth-order contributions from turns
4502
4503       use comm_locel
4504 !      implicit real*8 (a-h,o-z)
4505 !      include 'DIMENSIONS'
4506 !      include 'COMMON.IOUNITS'
4507 !      include 'COMMON.GEO'
4508 !      include 'COMMON.VAR'
4509 !      include 'COMMON.LOCAL'
4510 !      include 'COMMON.CHAIN'
4511 !      include 'COMMON.DERIV'
4512 !      include 'COMMON.INTERACT'
4513 !      include 'COMMON.CONTACTS'
4514 !      include 'COMMON.TORSION'
4515 !      include 'COMMON.VECTORS'
4516 !      include 'COMMON.FFIELD'
4517 !      include 'COMMON.CONTROL'
4518       real(kind=8),dimension(3) :: ggg
4519       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4520         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4521       real(kind=8),dimension(2) :: auxvec,auxvec1
4522 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4523       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4524 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4525 !el        dz_normi,xmedi,ymedi,zmedi
4526 !el      integer :: num_conti,j1,j2
4527 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4528 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4529 !el          num_conti,j1,j2
4530 !el local variables
4531       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4532       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4533          rlocshield
4534
4535       j=i+3
4536 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4537 !
4538 !               Fourth-order contributions
4539 !
4540 !                 (i+3)o----(i+4)
4541 !                     /  |
4542 !               (i+2)o   |
4543 !                     \  |
4544 !                 (i+1)o----i
4545 !
4546 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4547 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4548 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4549           zj=(c(3,j)+c(3,j+1))/2.0d0
4550           zj=mod(zj,boxzsize)
4551           if (zj.lt.0) zj=zj+boxzsize
4552        if ((zj.gt.bordlipbot)  &
4553         .and.(zj.lt.bordliptop)) then
4554 !C the energy transfer exist
4555         if (zj.lt.buflipbot) then
4556 !C what fraction I am in
4557          fracinbuf=1.0d0-     &
4558              ((zj-bordlipbot)/lipbufthick)
4559 !C lipbufthick is thickenes of lipid buffore
4560          sslipj=sscalelip(fracinbuf)
4561          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4562         elseif (zj.gt.bufliptop) then
4563          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4564          sslipj=sscalelip(fracinbuf)
4565          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4566         else
4567          sslipj=1.0d0
4568          ssgradlipj=0.0
4569         endif
4570        else
4571          sslipj=0.0d0
4572          ssgradlipj=0.0
4573        endif
4574
4575         a_temp(1,1)=a22
4576         a_temp(1,2)=a23
4577         a_temp(2,1)=a32
4578         a_temp(2,2)=a33
4579         iti1=itortyp(itype(i+1,1))
4580         iti2=itortyp(itype(i+2,1))
4581         iti3=itortyp(itype(i+3,1))
4582 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4583         call transpose2(EUg(1,1,i+1),e1t(1,1))
4584         call transpose2(Eug(1,1,i+2),e2t(1,1))
4585         call transpose2(Eug(1,1,i+3),e3t(1,1))
4586         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4587         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4588         s1=scalar2(b1(1,iti2),auxvec(1))
4589         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4590         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4591         s2=scalar2(b1(1,iti1),auxvec(1))
4592         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4593         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4594         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4595         if (shield_mode.eq.0) then
4596         fac_shield(i)=1.0
4597         fac_shield(j)=1.0
4598         endif
4599
4600         eello_turn4=eello_turn4-(s1+s2+s3) &
4601         *fac_shield(i)*fac_shield(j)       &
4602         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4603         eello_t4=-(s1+s2+s3)  &
4604           *fac_shield(i)*fac_shield(j)
4605 !C Now derivative over shield:
4606           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4607          (shield_mode.gt.0)) then
4608 !C          print *,i,j
4609
4610           do ilist=1,ishield_list(i)
4611            iresshield=shield_list(ilist,i)
4612            do k=1,3
4613            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4614            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4615                    rlocshield &
4616             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4617             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4618            +rlocshield
4619            enddo
4620           enddo
4621           do ilist=1,ishield_list(j)
4622            iresshield=shield_list(ilist,j)
4623            do k=1,3
4624            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4625            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4626                    rlocshield  &
4627            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4628            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4629                   +rlocshield
4630
4631            enddo
4632           enddo
4633
4634           do k=1,3
4635             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4636                    grad_shield(k,i)*eello_t4/fac_shield(i)
4637             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4638                    grad_shield(k,j)*eello_t4/fac_shield(j)
4639             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4640                    grad_shield(k,i)*eello_t4/fac_shield(i)
4641             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4642                    grad_shield(k,j)*eello_t4/fac_shield(j)
4643            enddo
4644            endif
4645
4646         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4647            'eturn4',i,j,-(s1+s2+s3)
4648 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4649 !d     &    ' eello_turn4_num',8*eello_turn4_num
4650 ! Derivatives in gamma(i)
4651         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4652         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4653         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4654         s1=scalar2(b1(1,iti2),auxvec(1))
4655         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4656         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4657         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4658        *fac_shield(i)*fac_shield(j)  &
4659        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4660
4661 ! Derivatives in gamma(i+1)
4662         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4663         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4664         s2=scalar2(b1(1,iti1),auxvec(1))
4665         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4666         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4667         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4668         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4669        *fac_shield(i)*fac_shield(j)  &
4670        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4671
4672 ! Derivatives in gamma(i+2)
4673         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4674         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4675         s1=scalar2(b1(1,iti2),auxvec(1))
4676         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4677         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4678         s2=scalar2(b1(1,iti1),auxvec(1))
4679         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4680         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4681         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4682         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4683        *fac_shield(i)*fac_shield(j)  &
4684        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4685
4686 ! Cartesian derivatives
4687 ! Derivatives of this turn contributions in DC(i+2)
4688         if (j.lt.nres-1) then
4689           do l=1,3
4690             a_temp(1,1)=agg(l,1)
4691             a_temp(1,2)=agg(l,2)
4692             a_temp(2,1)=agg(l,3)
4693             a_temp(2,2)=agg(l,4)
4694             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4695             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4696             s1=scalar2(b1(1,iti2),auxvec(1))
4697             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4698             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4699             s2=scalar2(b1(1,iti1),auxvec(1))
4700             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4701             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4702             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4703             ggg(l)=-(s1+s2+s3)
4704             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4705        *fac_shield(i)*fac_shield(j)  &
4706        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4707
4708           enddo
4709         endif
4710 ! Remaining derivatives of this turn contribution
4711         do l=1,3
4712           a_temp(1,1)=aggi(l,1)
4713           a_temp(1,2)=aggi(l,2)
4714           a_temp(2,1)=aggi(l,3)
4715           a_temp(2,2)=aggi(l,4)
4716           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4717           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4718           s1=scalar2(b1(1,iti2),auxvec(1))
4719           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4720           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4721           s2=scalar2(b1(1,iti1),auxvec(1))
4722           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4723           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4724           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4725           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4726          *fac_shield(i)*fac_shield(j)  &
4727          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4728
4729
4730           a_temp(1,1)=aggi1(l,1)
4731           a_temp(1,2)=aggi1(l,2)
4732           a_temp(2,1)=aggi1(l,3)
4733           a_temp(2,2)=aggi1(l,4)
4734           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4735           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4736           s1=scalar2(b1(1,iti2),auxvec(1))
4737           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4738           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4739           s2=scalar2(b1(1,iti1),auxvec(1))
4740           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4741           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4742           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4743           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4744          *fac_shield(i)*fac_shield(j)  &
4745          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4746
4747
4748           a_temp(1,1)=aggj(l,1)
4749           a_temp(1,2)=aggj(l,2)
4750           a_temp(2,1)=aggj(l,3)
4751           a_temp(2,2)=aggj(l,4)
4752           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4753           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4754           s1=scalar2(b1(1,iti2),auxvec(1))
4755           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4756           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4757           s2=scalar2(b1(1,iti1),auxvec(1))
4758           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4759           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4760           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4761           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4762          *fac_shield(i)*fac_shield(j)  &
4763          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4764
4765
4766           a_temp(1,1)=aggj1(l,1)
4767           a_temp(1,2)=aggj1(l,2)
4768           a_temp(2,1)=aggj1(l,3)
4769           a_temp(2,2)=aggj1(l,4)
4770           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4771           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4772           s1=scalar2(b1(1,iti2),auxvec(1))
4773           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4774           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4775           s2=scalar2(b1(1,iti1),auxvec(1))
4776           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4777           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4778           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4779 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4780           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4781          *fac_shield(i)*fac_shield(j)  &
4782          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4783
4784         enddo
4785          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4786           ssgradlipi*eello_t4/4.0d0*lipscale
4787          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4788           ssgradlipj*eello_t4/4.0d0*lipscale
4789          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4790           ssgradlipi*eello_t4/4.0d0*lipscale
4791          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4792           ssgradlipj*eello_t4/4.0d0*lipscale
4793
4794       return
4795       end subroutine eturn4
4796 !-----------------------------------------------------------------------------
4797       subroutine unormderiv(u,ugrad,unorm,ungrad)
4798 ! This subroutine computes the derivatives of a normalized vector u, given
4799 ! the derivatives computed without normalization conditions, ugrad. Returns
4800 ! ungrad.
4801 !      implicit none
4802       real(kind=8),dimension(3) :: u,vec
4803       real(kind=8),dimension(3,3) ::ugrad,ungrad
4804       real(kind=8) :: unorm      !,scalar
4805       integer :: i,j
4806 !      write (2,*) 'ugrad',ugrad
4807 !      write (2,*) 'u',u
4808       do i=1,3
4809         vec(i)=scalar(ugrad(1,i),u(1))
4810       enddo
4811 !      write (2,*) 'vec',vec
4812       do i=1,3
4813         do j=1,3
4814           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4815         enddo
4816       enddo
4817 !      write (2,*) 'ungrad',ungrad
4818       return
4819       end subroutine unormderiv
4820 !-----------------------------------------------------------------------------
4821       subroutine escp_soft_sphere(evdw2,evdw2_14)
4822 !
4823 ! This subroutine calculates the excluded-volume interaction energy between
4824 ! peptide-group centers and side chains and its gradient in virtual-bond and
4825 ! side-chain vectors.
4826 !
4827 !      implicit real*8 (a-h,o-z)
4828 !      include 'DIMENSIONS'
4829 !      include 'COMMON.GEO'
4830 !      include 'COMMON.VAR'
4831 !      include 'COMMON.LOCAL'
4832 !      include 'COMMON.CHAIN'
4833 !      include 'COMMON.DERIV'
4834 !      include 'COMMON.INTERACT'
4835 !      include 'COMMON.FFIELD'
4836 !      include 'COMMON.IOUNITS'
4837 !      include 'COMMON.CONTROL'
4838       real(kind=8),dimension(3) :: ggg
4839 !el local variables
4840       integer :: i,iint,j,k,iteli,itypj
4841       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4842                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4843
4844       evdw2=0.0D0
4845       evdw2_14=0.0d0
4846       r0_scp=4.5d0
4847 !d    print '(a)','Enter ESCP'
4848 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4849       do i=iatscp_s,iatscp_e
4850         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4851         iteli=itel(i)
4852         xi=0.5D0*(c(1,i)+c(1,i+1))
4853         yi=0.5D0*(c(2,i)+c(2,i+1))
4854         zi=0.5D0*(c(3,i)+c(3,i+1))
4855
4856         do iint=1,nscp_gr(i)
4857
4858         do j=iscpstart(i,iint),iscpend(i,iint)
4859           if (itype(j,1).eq.ntyp1) cycle
4860           itypj=iabs(itype(j,1))
4861 ! Uncomment following three lines for SC-p interactions
4862 !         xj=c(1,nres+j)-xi
4863 !         yj=c(2,nres+j)-yi
4864 !         zj=c(3,nres+j)-zi
4865 ! Uncomment following three lines for Ca-p interactions
4866           xj=c(1,j)-xi
4867           yj=c(2,j)-yi
4868           zj=c(3,j)-zi
4869           rij=xj*xj+yj*yj+zj*zj
4870           r0ij=r0_scp
4871           r0ijsq=r0ij*r0ij
4872           if (rij.lt.r0ijsq) then
4873             evdwij=0.25d0*(rij-r0ijsq)**2
4874             fac=rij-r0ijsq
4875           else
4876             evdwij=0.0d0
4877             fac=0.0d0
4878           endif
4879           evdw2=evdw2+evdwij
4880 !
4881 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4882 !
4883           ggg(1)=xj*fac
4884           ggg(2)=yj*fac
4885           ggg(3)=zj*fac
4886 !grad          if (j.lt.i) then
4887 !d          write (iout,*) 'j<i'
4888 ! Uncomment following three lines for SC-p interactions
4889 !           do k=1,3
4890 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4891 !           enddo
4892 !grad          else
4893 !d          write (iout,*) 'j>i'
4894 !grad            do k=1,3
4895 !grad              ggg(k)=-ggg(k)
4896 ! Uncomment following line for SC-p interactions
4897 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4898 !grad            enddo
4899 !grad          endif
4900 !grad          do k=1,3
4901 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4902 !grad          enddo
4903 !grad          kstart=min0(i+1,j)
4904 !grad          kend=max0(i-1,j-1)
4905 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4906 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4907 !grad          do k=kstart,kend
4908 !grad            do l=1,3
4909 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4910 !grad            enddo
4911 !grad          enddo
4912           do k=1,3
4913             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4914             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4915           enddo
4916         enddo
4917
4918         enddo ! iint
4919       enddo ! i
4920       return
4921       end subroutine escp_soft_sphere
4922 !-----------------------------------------------------------------------------
4923       subroutine escp(evdw2,evdw2_14)
4924 !
4925 ! This subroutine calculates the excluded-volume interaction energy between
4926 ! peptide-group centers and side chains and its gradient in virtual-bond and
4927 ! side-chain vectors.
4928 !
4929 !      implicit real*8 (a-h,o-z)
4930 !      include 'DIMENSIONS'
4931 !      include 'COMMON.GEO'
4932 !      include 'COMMON.VAR'
4933 !      include 'COMMON.LOCAL'
4934 !      include 'COMMON.CHAIN'
4935 !      include 'COMMON.DERIV'
4936 !      include 'COMMON.INTERACT'
4937 !      include 'COMMON.FFIELD'
4938 !      include 'COMMON.IOUNITS'
4939 !      include 'COMMON.CONTROL'
4940       real(kind=8),dimension(3) :: ggg
4941 !el local variables
4942       integer :: i,iint,j,k,iteli,itypj,subchap
4943       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4944                    e1,e2,evdwij,rij
4945       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4946                     dist_temp, dist_init
4947       integer xshift,yshift,zshift
4948
4949       evdw2=0.0D0
4950       evdw2_14=0.0d0
4951 !d    print '(a)','Enter ESCP'
4952 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4953       do i=iatscp_s,iatscp_e
4954         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4955         iteli=itel(i)
4956         xi=0.5D0*(c(1,i)+c(1,i+1))
4957         yi=0.5D0*(c(2,i)+c(2,i+1))
4958         zi=0.5D0*(c(3,i)+c(3,i+1))
4959           xi=mod(xi,boxxsize)
4960           if (xi.lt.0) xi=xi+boxxsize
4961           yi=mod(yi,boxysize)
4962           if (yi.lt.0) yi=yi+boxysize
4963           zi=mod(zi,boxzsize)
4964           if (zi.lt.0) zi=zi+boxzsize
4965
4966         do iint=1,nscp_gr(i)
4967
4968         do j=iscpstart(i,iint),iscpend(i,iint)
4969           itypj=iabs(itype(j,1))
4970           if (itypj.eq.ntyp1) cycle
4971 ! Uncomment following three lines for SC-p interactions
4972 !         xj=c(1,nres+j)-xi
4973 !         yj=c(2,nres+j)-yi
4974 !         zj=c(3,nres+j)-zi
4975 ! Uncomment following three lines for Ca-p interactions
4976 !          xj=c(1,j)-xi
4977 !          yj=c(2,j)-yi
4978 !          zj=c(3,j)-zi
4979           xj=c(1,j)
4980           yj=c(2,j)
4981           zj=c(3,j)
4982           xj=mod(xj,boxxsize)
4983           if (xj.lt.0) xj=xj+boxxsize
4984           yj=mod(yj,boxysize)
4985           if (yj.lt.0) yj=yj+boxysize
4986           zj=mod(zj,boxzsize)
4987           if (zj.lt.0) zj=zj+boxzsize
4988       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4989       xj_safe=xj
4990       yj_safe=yj
4991       zj_safe=zj
4992       subchap=0
4993       do xshift=-1,1
4994       do yshift=-1,1
4995       do zshift=-1,1
4996           xj=xj_safe+xshift*boxxsize
4997           yj=yj_safe+yshift*boxysize
4998           zj=zj_safe+zshift*boxzsize
4999           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5000           if(dist_temp.lt.dist_init) then
5001             dist_init=dist_temp
5002             xj_temp=xj
5003             yj_temp=yj
5004             zj_temp=zj
5005             subchap=1
5006           endif
5007        enddo
5008        enddo
5009        enddo
5010        if (subchap.eq.1) then
5011           xj=xj_temp-xi
5012           yj=yj_temp-yi
5013           zj=zj_temp-zi
5014        else
5015           xj=xj_safe-xi
5016           yj=yj_safe-yi
5017           zj=zj_safe-zi
5018        endif
5019
5020           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5021           rij=dsqrt(1.0d0/rrij)
5022             sss_ele_cut=sscale_ele(rij)
5023             sss_ele_grad=sscagrad_ele(rij)
5024 !            print *,sss_ele_cut,sss_ele_grad,&
5025 !            (rij),r_cut_ele,rlamb_ele
5026             if (sss_ele_cut.le.0.0) cycle
5027           fac=rrij**expon2
5028           e1=fac*fac*aad(itypj,iteli)
5029           e2=fac*bad(itypj,iteli)
5030           if (iabs(j-i) .le. 2) then
5031             e1=scal14*e1
5032             e2=scal14*e2
5033             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5034           endif
5035           evdwij=e1+e2
5036           evdw2=evdw2+evdwij*sss_ele_cut
5037 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5038 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5039           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5040              'evdw2',i,j,evdwij
5041 !
5042 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5043 !
5044           fac=-(evdwij+e1)*rrij*sss_ele_cut
5045           fac=fac+evdwij*sss_ele_grad/rij/expon
5046           ggg(1)=xj*fac
5047           ggg(2)=yj*fac
5048           ggg(3)=zj*fac
5049 !grad          if (j.lt.i) then
5050 !d          write (iout,*) 'j<i'
5051 ! Uncomment following three lines for SC-p interactions
5052 !           do k=1,3
5053 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5054 !           enddo
5055 !grad          else
5056 !d          write (iout,*) 'j>i'
5057 !grad            do k=1,3
5058 !grad              ggg(k)=-ggg(k)
5059 ! Uncomment following line for SC-p interactions
5060 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5061 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5062 !grad            enddo
5063 !grad          endif
5064 !grad          do k=1,3
5065 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5066 !grad          enddo
5067 !grad          kstart=min0(i+1,j)
5068 !grad          kend=max0(i-1,j-1)
5069 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5070 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5071 !grad          do k=kstart,kend
5072 !grad            do l=1,3
5073 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5074 !grad            enddo
5075 !grad          enddo
5076           do k=1,3
5077             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5078             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5079           enddo
5080         enddo
5081
5082         enddo ! iint
5083       enddo ! i
5084       do i=1,nct
5085         do j=1,3
5086           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5087           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5088           gradx_scp(j,i)=expon*gradx_scp(j,i)
5089         enddo
5090       enddo
5091 !******************************************************************************
5092 !
5093 !                              N O T E !!!
5094 !
5095 ! To save time the factor EXPON has been extracted from ALL components
5096 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5097 ! use!
5098 !
5099 !******************************************************************************
5100       return
5101       end subroutine escp
5102 !-----------------------------------------------------------------------------
5103       subroutine edis(ehpb)
5104 !
5105 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5106 !
5107 !      implicit real*8 (a-h,o-z)
5108 !      include 'DIMENSIONS'
5109 !      include 'COMMON.SBRIDGE'
5110 !      include 'COMMON.CHAIN'
5111 !      include 'COMMON.DERIV'
5112 !      include 'COMMON.VAR'
5113 !      include 'COMMON.INTERACT'
5114 !      include 'COMMON.IOUNITS'
5115       real(kind=8),dimension(3) :: ggg
5116 !el local variables
5117       integer :: i,j,ii,jj,iii,jjj,k
5118       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5119
5120       ehpb=0.0D0
5121 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5122 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5123       if (link_end.eq.0) return
5124       do i=link_start,link_end
5125 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5126 ! CA-CA distance used in regularization of structure.
5127         ii=ihpb(i)
5128         jj=jhpb(i)
5129 ! iii and jjj point to the residues for which the distance is assigned.
5130         if (ii.gt.nres) then
5131           iii=ii-nres
5132           jjj=jj-nres
5133         else
5134           iii=ii
5135           jjj=jj
5136         endif
5137 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5138 !     &    dhpb(i),dhpb1(i),forcon(i)
5139 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5140 !    distance and angle dependent SS bond potential.
5141 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5142 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5143         if (.not.dyn_ss .and. i.le.nss) then
5144 ! 15/02/13 CC dynamic SSbond - additional check
5145          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5146         iabs(itype(jjj,1)).eq.1) then
5147           call ssbond_ene(iii,jjj,eij)
5148           ehpb=ehpb+2*eij
5149 !d          write (iout,*) "eij",eij
5150          endif
5151         else if (ii.gt.nres .and. jj.gt.nres) then
5152 !c Restraints from contact prediction
5153           dd=dist(ii,jj)
5154           if (constr_dist.eq.11) then
5155             ehpb=ehpb+fordepth(i)**4.0d0 &
5156                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5157             fac=fordepth(i)**4.0d0 &
5158                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5159           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5160             ehpb,fordepth(i),dd
5161            else
5162           if (dhpb1(i).gt.0.0d0) then
5163             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5164             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5165 !c            write (iout,*) "beta nmr",
5166 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5167           else
5168             dd=dist(ii,jj)
5169             rdis=dd-dhpb(i)
5170 !C Get the force constant corresponding to this distance.
5171             waga=forcon(i)
5172 !C Calculate the contribution to energy.
5173             ehpb=ehpb+waga*rdis*rdis
5174 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5175 !C
5176 !C Evaluate gradient.
5177 !C
5178             fac=waga*rdis/dd
5179           endif
5180           endif
5181           do j=1,3
5182             ggg(j)=fac*(c(j,jj)-c(j,ii))
5183           enddo
5184           do j=1,3
5185             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5186             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5187           enddo
5188           do k=1,3
5189             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5190             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5191           enddo
5192         else
5193           dd=dist(ii,jj)
5194           if (constr_dist.eq.11) then
5195             ehpb=ehpb+fordepth(i)**4.0d0 &
5196                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5197             fac=fordepth(i)**4.0d0 &
5198                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5199           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5200          ehpb,fordepth(i),dd
5201            else
5202           if (dhpb1(i).gt.0.0d0) then
5203             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5204             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5205 !c            write (iout,*) "alph nmr",
5206 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5207           else
5208             rdis=dd-dhpb(i)
5209 !C Get the force constant corresponding to this distance.
5210             waga=forcon(i)
5211 !C Calculate the contribution to energy.
5212             ehpb=ehpb+waga*rdis*rdis
5213 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5214 !C
5215 !C Evaluate gradient.
5216 !C
5217             fac=waga*rdis/dd
5218           endif
5219           endif
5220
5221             do j=1,3
5222               ggg(j)=fac*(c(j,jj)-c(j,ii))
5223             enddo
5224 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5225 !C If this is a SC-SC distance, we need to calculate the contributions to the
5226 !C Cartesian gradient in the SC vectors (ghpbx).
5227           if (iii.lt.ii) then
5228           do j=1,3
5229             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5230             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5231           enddo
5232           endif
5233 !cgrad        do j=iii,jjj-1
5234 !cgrad          do k=1,3
5235 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5236 !cgrad          enddo
5237 !cgrad        enddo
5238           do k=1,3
5239             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5240             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5241           enddo
5242         endif
5243       enddo
5244       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5245
5246       return
5247       end subroutine edis
5248 !-----------------------------------------------------------------------------
5249       subroutine ssbond_ene(i,j,eij)
5250 !
5251 ! Calculate the distance and angle dependent SS-bond potential energy
5252 ! using a free-energy function derived based on RHF/6-31G** ab initio
5253 ! calculations of diethyl disulfide.
5254 !
5255 ! A. Liwo and U. Kozlowska, 11/24/03
5256 !
5257 !      implicit real*8 (a-h,o-z)
5258 !      include 'DIMENSIONS'
5259 !      include 'COMMON.SBRIDGE'
5260 !      include 'COMMON.CHAIN'
5261 !      include 'COMMON.DERIV'
5262 !      include 'COMMON.LOCAL'
5263 !      include 'COMMON.INTERACT'
5264 !      include 'COMMON.VAR'
5265 !      include 'COMMON.IOUNITS'
5266       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5267 !el local variables
5268       integer :: i,j,itypi,itypj,k
5269       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5270                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5271                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5272                    cosphi,ggk
5273
5274       itypi=iabs(itype(i,1))
5275       xi=c(1,nres+i)
5276       yi=c(2,nres+i)
5277       zi=c(3,nres+i)
5278       dxi=dc_norm(1,nres+i)
5279       dyi=dc_norm(2,nres+i)
5280       dzi=dc_norm(3,nres+i)
5281 !      dsci_inv=dsc_inv(itypi)
5282       dsci_inv=vbld_inv(nres+i)
5283       itypj=iabs(itype(j,1))
5284 !      dscj_inv=dsc_inv(itypj)
5285       dscj_inv=vbld_inv(nres+j)
5286       xj=c(1,nres+j)-xi
5287       yj=c(2,nres+j)-yi
5288       zj=c(3,nres+j)-zi
5289       dxj=dc_norm(1,nres+j)
5290       dyj=dc_norm(2,nres+j)
5291       dzj=dc_norm(3,nres+j)
5292       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5293       rij=dsqrt(rrij)
5294       erij(1)=xj*rij
5295       erij(2)=yj*rij
5296       erij(3)=zj*rij
5297       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5298       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5299       om12=dxi*dxj+dyi*dyj+dzi*dzj
5300       do k=1,3
5301         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5302         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5303       enddo
5304       rij=1.0d0/rij
5305       deltad=rij-d0cm
5306       deltat1=1.0d0-om1
5307       deltat2=1.0d0+om2
5308       deltat12=om2-om1+2.0d0
5309       cosphi=om12-om1*om2
5310       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5311         +akct*deltad*deltat12 &
5312         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5313 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5314 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5315 !     &  " deltat12",deltat12," eij",eij
5316       ed=2*akcm*deltad+akct*deltat12
5317       pom1=akct*deltad
5318       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5319       eom1=-2*akth*deltat1-pom1-om2*pom2
5320       eom2= 2*akth*deltat2+pom1-om1*pom2
5321       eom12=pom2
5322       do k=1,3
5323         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5324         ghpbx(k,i)=ghpbx(k,i)-ggk &
5325                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5326                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5327         ghpbx(k,j)=ghpbx(k,j)+ggk &
5328                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5329                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5330         ghpbc(k,i)=ghpbc(k,i)-ggk
5331         ghpbc(k,j)=ghpbc(k,j)+ggk
5332       enddo
5333 !
5334 ! Calculate the components of the gradient in DC and X
5335 !
5336 !grad      do k=i,j-1
5337 !grad        do l=1,3
5338 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5339 !grad        enddo
5340 !grad      enddo
5341       return
5342       end subroutine ssbond_ene
5343 !-----------------------------------------------------------------------------
5344       subroutine ebond(estr)
5345 !
5346 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5347 !
5348 !      implicit real*8 (a-h,o-z)
5349 !      include 'DIMENSIONS'
5350 !      include 'COMMON.LOCAL'
5351 !      include 'COMMON.GEO'
5352 !      include 'COMMON.INTERACT'
5353 !      include 'COMMON.DERIV'
5354 !      include 'COMMON.VAR'
5355 !      include 'COMMON.CHAIN'
5356 !      include 'COMMON.IOUNITS'
5357 !      include 'COMMON.NAMES'
5358 !      include 'COMMON.FFIELD'
5359 !      include 'COMMON.CONTROL'
5360 !      include 'COMMON.SETUP'
5361       real(kind=8),dimension(3) :: u,ud
5362 !el local variables
5363       integer :: i,j,iti,nbi,k
5364       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5365                    uprod1,uprod2
5366
5367       estr=0.0d0
5368       estr1=0.0d0
5369 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5370 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5371
5372       do i=ibondp_start,ibondp_end
5373         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5374         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5375 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5376 !C          do j=1,3
5377 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5378 !C            *dc(j,i-1)/vbld(i)
5379 !C          enddo
5380 !C          if (energy_dec) write(iout,*) &
5381 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5382         diff = vbld(i)-vbldpDUM
5383         else
5384         diff = vbld(i)-vbldp0
5385         endif
5386         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5387            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5388         estr=estr+diff*diff
5389         do j=1,3
5390           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5391         enddo
5392 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5393 !        endif
5394       enddo
5395       estr=0.5d0*AKP*estr+estr1
5396 !      print *,"estr_bb",estr,AKP
5397 !
5398 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5399 !
5400       do i=ibond_start,ibond_end
5401         iti=iabs(itype(i,1))
5402         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5403         if (iti.ne.10 .and. iti.ne.ntyp1) then
5404           nbi=nbondterm(iti)
5405           if (nbi.eq.1) then
5406             diff=vbld(i+nres)-vbldsc0(1,iti)
5407             if (energy_dec) write (iout,*) &
5408             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5409             AKSC(1,iti),AKSC(1,iti)*diff*diff
5410             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5411 !            print *,"estr_sc",estr
5412             do j=1,3
5413               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5414             enddo
5415           else
5416             do j=1,nbi
5417               diff=vbld(i+nres)-vbldsc0(j,iti)
5418               ud(j)=aksc(j,iti)*diff
5419               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5420             enddo
5421             uprod=u(1)
5422             do j=2,nbi
5423               uprod=uprod*u(j)
5424             enddo
5425             usum=0.0d0
5426             usumsqder=0.0d0
5427             do j=1,nbi
5428               uprod1=1.0d0
5429               uprod2=1.0d0
5430               do k=1,nbi
5431                 if (k.ne.j) then
5432                   uprod1=uprod1*u(k)
5433                   uprod2=uprod2*u(k)*u(k)
5434                 endif
5435               enddo
5436               usum=usum+uprod1
5437               usumsqder=usumsqder+ud(j)*uprod2
5438             enddo
5439             estr=estr+uprod/usum
5440 !            print *,"estr_sc",estr,i
5441
5442              if (energy_dec) write (iout,*) &
5443             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5444             AKSC(1,iti),uprod/usum
5445             do j=1,3
5446              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5447             enddo
5448           endif
5449         endif
5450       enddo
5451       return
5452       end subroutine ebond
5453 #ifdef CRYST_THETA
5454 !-----------------------------------------------------------------------------
5455       subroutine ebend(etheta)
5456 !
5457 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5458 ! angles gamma and its derivatives in consecutive thetas and gammas.
5459 !
5460       use comm_calcthet
5461 !      implicit real*8 (a-h,o-z)
5462 !      include 'DIMENSIONS'
5463 !      include 'COMMON.LOCAL'
5464 !      include 'COMMON.GEO'
5465 !      include 'COMMON.INTERACT'
5466 !      include 'COMMON.DERIV'
5467 !      include 'COMMON.VAR'
5468 !      include 'COMMON.CHAIN'
5469 !      include 'COMMON.IOUNITS'
5470 !      include 'COMMON.NAMES'
5471 !      include 'COMMON.FFIELD'
5472 !      include 'COMMON.CONTROL'
5473 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5474 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5475 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5476 !el      integer :: it
5477 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5478 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5479 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5480 !el local variables
5481       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5482        ichir21,ichir22
5483       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5484        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5485        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5486       real(kind=8),dimension(2) :: y,z
5487
5488       delta=0.02d0*pi
5489 !      time11=dexp(-2*time)
5490 !      time12=1.0d0
5491       etheta=0.0D0
5492 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5493       do i=ithet_start,ithet_end
5494         if (itype(i-1,1).eq.ntyp1) cycle
5495 ! Zero the energy function and its derivative at 0 or pi.
5496         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5497         it=itype(i-1,1)
5498         ichir1=isign(1,itype(i-2,1))
5499         ichir2=isign(1,itype(i,1))
5500          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5501          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5502          if (itype(i-1,1).eq.10) then
5503           itype1=isign(10,itype(i-2,1))
5504           ichir11=isign(1,itype(i-2,1))
5505           ichir12=isign(1,itype(i-2,1))
5506           itype2=isign(10,itype(i,1))
5507           ichir21=isign(1,itype(i,1))
5508           ichir22=isign(1,itype(i,1))
5509          endif
5510
5511         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5512 #ifdef OSF
5513           phii=phi(i)
5514           if (phii.ne.phii) phii=150.0
5515 #else
5516           phii=phi(i)
5517 #endif
5518           y(1)=dcos(phii)
5519           y(2)=dsin(phii)
5520         else
5521           y(1)=0.0D0
5522           y(2)=0.0D0
5523         endif
5524         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5525 #ifdef OSF
5526           phii1=phi(i+1)
5527           if (phii1.ne.phii1) phii1=150.0
5528           phii1=pinorm(phii1)
5529           z(1)=cos(phii1)
5530 #else
5531           phii1=phi(i+1)
5532           z(1)=dcos(phii1)
5533 #endif
5534           z(2)=dsin(phii1)
5535         else
5536           z(1)=0.0D0
5537           z(2)=0.0D0
5538         endif
5539 ! Calculate the "mean" value of theta from the part of the distribution
5540 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5541 ! In following comments this theta will be referred to as t_c.
5542         thet_pred_mean=0.0d0
5543         do k=1,2
5544             athetk=athet(k,it,ichir1,ichir2)
5545             bthetk=bthet(k,it,ichir1,ichir2)
5546           if (it.eq.10) then
5547              athetk=athet(k,itype1,ichir11,ichir12)
5548              bthetk=bthet(k,itype2,ichir21,ichir22)
5549           endif
5550          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5551         enddo
5552         dthett=thet_pred_mean*ssd
5553         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5554 ! Derivatives of the "mean" values in gamma1 and gamma2.
5555         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5556                +athet(2,it,ichir1,ichir2)*y(1))*ss
5557         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5558                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5559          if (it.eq.10) then
5560         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5561              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5562         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5563                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5564          endif
5565         if (theta(i).gt.pi-delta) then
5566           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5567                E_tc0)
5568           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5569           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5570           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5571               E_theta)
5572           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5573               E_tc)
5574         else if (theta(i).lt.delta) then
5575           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5576           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5577           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5578               E_theta)
5579           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5580           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5581               E_tc)
5582         else
5583           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5584               E_theta,E_tc)
5585         endif
5586         etheta=etheta+ethetai
5587         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5588             'ebend',i,ethetai
5589         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5590         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5591         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5592       enddo
5593 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5594
5595 ! Ufff.... We've done all this!!!
5596       return
5597       end subroutine ebend
5598 !-----------------------------------------------------------------------------
5599       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5600
5601       use comm_calcthet
5602 !      implicit real*8 (a-h,o-z)
5603 !      include 'DIMENSIONS'
5604 !      include 'COMMON.LOCAL'
5605 !      include 'COMMON.IOUNITS'
5606 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5607 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5608 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5609       integer :: i,j,k
5610       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5611 !el      integer :: it
5612 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5613 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5614 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5615 !el local variables
5616       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5617        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5618
5619 ! Calculate the contributions to both Gaussian lobes.
5620 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5621 ! The "polynomial part" of the "standard deviation" of this part of
5622 ! the distribution.
5623         sig=polthet(3,it)
5624         do j=2,0,-1
5625           sig=sig*thet_pred_mean+polthet(j,it)
5626         enddo
5627 ! Derivative of the "interior part" of the "standard deviation of the"
5628 ! gamma-dependent Gaussian lobe in t_c.
5629         sigtc=3*polthet(3,it)
5630         do j=2,1,-1
5631           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5632         enddo
5633         sigtc=sig*sigtc
5634 ! Set the parameters of both Gaussian lobes of the distribution.
5635 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5636         fac=sig*sig+sigc0(it)
5637         sigcsq=fac+fac
5638         sigc=1.0D0/sigcsq
5639 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5640         sigsqtc=-4.0D0*sigcsq*sigtc
5641 !       print *,i,sig,sigtc,sigsqtc
5642 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5643         sigtc=-sigtc/(fac*fac)
5644 ! Following variable is sigma(t_c)**(-2)
5645         sigcsq=sigcsq*sigcsq
5646         sig0i=sig0(it)
5647         sig0inv=1.0D0/sig0i**2
5648         delthec=thetai-thet_pred_mean
5649         delthe0=thetai-theta0i
5650         term1=-0.5D0*sigcsq*delthec*delthec
5651         term2=-0.5D0*sig0inv*delthe0*delthe0
5652 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5653 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5654 ! to the energy (this being the log of the distribution) at the end of energy
5655 ! term evaluation for this virtual-bond angle.
5656         if (term1.gt.term2) then
5657           termm=term1
5658           term2=dexp(term2-termm)
5659           term1=1.0d0
5660         else
5661           termm=term2
5662           term1=dexp(term1-termm)
5663           term2=1.0d0
5664         endif
5665 ! The ratio between the gamma-independent and gamma-dependent lobes of
5666 ! the distribution is a Gaussian function of thet_pred_mean too.
5667         diffak=gthet(2,it)-thet_pred_mean
5668         ratak=diffak/gthet(3,it)**2
5669         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5670 ! Let's differentiate it in thet_pred_mean NOW.
5671         aktc=ak*ratak
5672 ! Now put together the distribution terms to make complete distribution.
5673         termexp=term1+ak*term2
5674         termpre=sigc+ak*sig0i
5675 ! Contribution of the bending energy from this theta is just the -log of
5676 ! the sum of the contributions from the two lobes and the pre-exponential
5677 ! factor. Simple enough, isn't it?
5678         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5679 ! NOW the derivatives!!!
5680 ! 6/6/97 Take into account the deformation.
5681         E_theta=(delthec*sigcsq*term1 &
5682              +ak*delthe0*sig0inv*term2)/termexp
5683         E_tc=((sigtc+aktc*sig0i)/termpre &
5684             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5685              aktc*term2)/termexp)
5686       return
5687       end subroutine theteng
5688 #else
5689 !-----------------------------------------------------------------------------
5690       subroutine ebend(etheta,ethetacnstr)
5691 !
5692 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5693 ! angles gamma and its derivatives in consecutive thetas and gammas.
5694 ! ab initio-derived potentials from
5695 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5696 !
5697 !      implicit real*8 (a-h,o-z)
5698 !      include 'DIMENSIONS'
5699 !      include 'COMMON.LOCAL'
5700 !      include 'COMMON.GEO'
5701 !      include 'COMMON.INTERACT'
5702 !      include 'COMMON.DERIV'
5703 !      include 'COMMON.VAR'
5704 !      include 'COMMON.CHAIN'
5705 !      include 'COMMON.IOUNITS'
5706 !      include 'COMMON.NAMES'
5707 !      include 'COMMON.FFIELD'
5708 !      include 'COMMON.CONTROL'
5709       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5710       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5711       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5712       logical :: lprn=.false., lprn1=.false.
5713 !el local variables
5714       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5715       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5716       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5717 ! local variables for constrains
5718       real(kind=8) :: difi,thetiii
5719        integer itheta
5720
5721       etheta=0.0D0
5722       do i=ithet_start,ithet_end
5723         if (itype(i-1,1).eq.ntyp1) cycle
5724         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5725         if (iabs(itype(i+1,1)).eq.20) iblock=2
5726         if (iabs(itype(i+1,1)).ne.20) iblock=1
5727         dethetai=0.0d0
5728         dephii=0.0d0
5729         dephii1=0.0d0
5730         theti2=0.5d0*theta(i)
5731         ityp2=ithetyp((itype(i-1,1)))
5732         do k=1,nntheterm
5733           coskt(k)=dcos(k*theti2)
5734           sinkt(k)=dsin(k*theti2)
5735         enddo
5736         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5737 #ifdef OSF
5738           phii=phi(i)
5739           if (phii.ne.phii) phii=150.0
5740 #else
5741           phii=phi(i)
5742 #endif
5743           ityp1=ithetyp((itype(i-2,1)))
5744 ! propagation of chirality for glycine type
5745           do k=1,nsingle
5746             cosph1(k)=dcos(k*phii)
5747             sinph1(k)=dsin(k*phii)
5748           enddo
5749         else
5750           phii=0.0d0
5751           ityp1=ithetyp(itype(i-2,1))
5752           do k=1,nsingle
5753             cosph1(k)=0.0d0
5754             sinph1(k)=0.0d0
5755           enddo
5756         endif
5757         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5758 #ifdef OSF
5759           phii1=phi(i+1)
5760           if (phii1.ne.phii1) phii1=150.0
5761           phii1=pinorm(phii1)
5762 #else
5763           phii1=phi(i+1)
5764 #endif
5765           ityp3=ithetyp((itype(i,1)))
5766           do k=1,nsingle
5767             cosph2(k)=dcos(k*phii1)
5768             sinph2(k)=dsin(k*phii1)
5769           enddo
5770         else
5771           phii1=0.0d0
5772           ityp3=ithetyp(itype(i,1))
5773           do k=1,nsingle
5774             cosph2(k)=0.0d0
5775             sinph2(k)=0.0d0
5776           enddo
5777         endif
5778         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5779         do k=1,ndouble
5780           do l=1,k-1
5781             ccl=cosph1(l)*cosph2(k-l)
5782             ssl=sinph1(l)*sinph2(k-l)
5783             scl=sinph1(l)*cosph2(k-l)
5784             csl=cosph1(l)*sinph2(k-l)
5785             cosph1ph2(l,k)=ccl-ssl
5786             cosph1ph2(k,l)=ccl+ssl
5787             sinph1ph2(l,k)=scl+csl
5788             sinph1ph2(k,l)=scl-csl
5789           enddo
5790         enddo
5791         if (lprn) then
5792         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5793           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5794         write (iout,*) "coskt and sinkt"
5795         do k=1,nntheterm
5796           write (iout,*) k,coskt(k),sinkt(k)
5797         enddo
5798         endif
5799         do k=1,ntheterm
5800           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5801           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5802             *coskt(k)
5803           if (lprn) &
5804           write (iout,*) "k",k,&
5805            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5806            " ethetai",ethetai
5807         enddo
5808         if (lprn) then
5809         write (iout,*) "cosph and sinph"
5810         do k=1,nsingle
5811           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5812         enddo
5813         write (iout,*) "cosph1ph2 and sinph2ph2"
5814         do k=2,ndouble
5815           do l=1,k-1
5816             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5817                sinph1ph2(l,k),sinph1ph2(k,l)
5818           enddo
5819         enddo
5820         write(iout,*) "ethetai",ethetai
5821         endif
5822         do m=1,ntheterm2
5823           do k=1,nsingle
5824             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5825                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5826                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5827                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5828             ethetai=ethetai+sinkt(m)*aux
5829             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5830             dephii=dephii+k*sinkt(m)* &
5831                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5832                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5833             dephii1=dephii1+k*sinkt(m)* &
5834                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5835                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5836             if (lprn) &
5837             write (iout,*) "m",m," k",k," bbthet", &
5838                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5839                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5840                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5841                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5842           enddo
5843         enddo
5844         if (lprn) &
5845         write(iout,*) "ethetai",ethetai
5846         do m=1,ntheterm3
5847           do k=2,ndouble
5848             do l=1,k-1
5849               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5850                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5851                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5852                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5853               ethetai=ethetai+sinkt(m)*aux
5854               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5855               dephii=dephii+l*sinkt(m)* &
5856                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5857                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5858                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5859                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5860               dephii1=dephii1+(k-l)*sinkt(m)* &
5861                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5862                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5863                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5864                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5865               if (lprn) then
5866               write (iout,*) "m",m," k",k," l",l," ffthet",&
5867                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5868                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5869                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5870                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5871                   " ethetai",ethetai
5872               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5873                   cosph1ph2(k,l)*sinkt(m),&
5874                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5875               endif
5876             enddo
5877           enddo
5878         enddo
5879 10      continue
5880 !        lprn1=.true.
5881         if (lprn1) &
5882           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5883          i,theta(i)*rad2deg,phii*rad2deg,&
5884          phii1*rad2deg,ethetai
5885 !        lprn1=.false.
5886         etheta=etheta+ethetai
5887         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5888                                     'ebend',i,ethetai
5889         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5890         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5891         gloc(nphi+i-2,icg)=wang*dethetai
5892       enddo
5893 !-----------thete constrains
5894 !      if (tor_mode.ne.2) then
5895       ethetacnstr=0.0d0
5896 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5897       do i=ithetaconstr_start,ithetaconstr_end
5898         itheta=itheta_constr(i)
5899         thetiii=theta(itheta)
5900         difi=pinorm(thetiii-theta_constr0(i))
5901         if (difi.gt.theta_drange(i)) then
5902           difi=difi-theta_drange(i)
5903           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5904           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5905          +for_thet_constr(i)*difi**3
5906         else if (difi.lt.-drange(i)) then
5907           difi=difi+drange(i)
5908           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5909           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5910          +for_thet_constr(i)*difi**3
5911         else
5912           difi=0.0
5913         endif
5914        if (energy_dec) then
5915         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5916          i,itheta,rad2deg*thetiii, &
5917          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5918          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5919          gloc(itheta+nphi-2,icg)
5920         endif
5921       enddo
5922 !      endif
5923
5924       return
5925       end subroutine ebend
5926 #endif
5927 #ifdef CRYST_SC
5928 !-----------------------------------------------------------------------------
5929       subroutine esc(escloc)
5930 ! Calculate the local energy of a side chain and its derivatives in the
5931 ! corresponding virtual-bond valence angles THETA and the spherical angles
5932 ! ALPHA and OMEGA.
5933 !
5934       use comm_sccalc
5935 !      implicit real*8 (a-h,o-z)
5936 !      include 'DIMENSIONS'
5937 !      include 'COMMON.GEO'
5938 !      include 'COMMON.LOCAL'
5939 !      include 'COMMON.VAR'
5940 !      include 'COMMON.INTERACT'
5941 !      include 'COMMON.DERIV'
5942 !      include 'COMMON.CHAIN'
5943 !      include 'COMMON.IOUNITS'
5944 !      include 'COMMON.NAMES'
5945 !      include 'COMMON.FFIELD'
5946 !      include 'COMMON.CONTROL'
5947       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5948          ddersc0,ddummy,xtemp,temp
5949 !el      real(kind=8) :: time11,time12,time112,theti
5950       real(kind=8) :: escloc,delta
5951 !el      integer :: it,nlobit
5952 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5953 !el local variables
5954       integer :: i,k
5955       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5956        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5957       delta=0.02d0*pi
5958       escloc=0.0D0
5959 !     write (iout,'(a)') 'ESC'
5960       do i=loc_start,loc_end
5961         it=itype(i,1)
5962         if (it.eq.ntyp1) cycle
5963         if (it.eq.10) goto 1
5964         nlobit=nlob(iabs(it))
5965 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5966 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5967         theti=theta(i+1)-pipol
5968         x(1)=dtan(theti)
5969         x(2)=alph(i)
5970         x(3)=omeg(i)
5971
5972         if (x(2).gt.pi-delta) then
5973           xtemp(1)=x(1)
5974           xtemp(2)=pi-delta
5975           xtemp(3)=x(3)
5976           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5977           xtemp(2)=pi
5978           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5979           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5980               escloci,dersc(2))
5981           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5982               ddersc0(1),dersc(1))
5983           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5984               ddersc0(3),dersc(3))
5985           xtemp(2)=pi-delta
5986           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5987           xtemp(2)=pi
5988           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5989           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5990                   dersc0(2),esclocbi,dersc02)
5991           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5992                   dersc12,dersc01)
5993           call splinthet(x(2),0.5d0*delta,ss,ssd)
5994           dersc0(1)=dersc01
5995           dersc0(2)=dersc02
5996           dersc0(3)=0.0d0
5997           do k=1,3
5998             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5999           enddo
6000           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6001 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6002 !    &             esclocbi,ss,ssd
6003           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6004 !         escloci=esclocbi
6005 !         write (iout,*) escloci
6006         else if (x(2).lt.delta) then
6007           xtemp(1)=x(1)
6008           xtemp(2)=delta
6009           xtemp(3)=x(3)
6010           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6011           xtemp(2)=0.0d0
6012           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6013           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6014               escloci,dersc(2))
6015           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6016               ddersc0(1),dersc(1))
6017           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6018               ddersc0(3),dersc(3))
6019           xtemp(2)=delta
6020           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6021           xtemp(2)=0.0d0
6022           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6023           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6024                   dersc0(2),esclocbi,dersc02)
6025           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6026                   dersc12,dersc01)
6027           dersc0(1)=dersc01
6028           dersc0(2)=dersc02
6029           dersc0(3)=0.0d0
6030           call splinthet(x(2),0.5d0*delta,ss,ssd)
6031           do k=1,3
6032             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6033           enddo
6034           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6035 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6036 !    &             esclocbi,ss,ssd
6037           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6038 !         write (iout,*) escloci
6039         else
6040           call enesc(x,escloci,dersc,ddummy,.false.)
6041         endif
6042
6043         escloc=escloc+escloci
6044         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6045            'escloc',i,escloci
6046 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6047
6048         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6049          wscloc*dersc(1)
6050         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6051         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6052     1   continue
6053       enddo
6054       return
6055       end subroutine esc
6056 !-----------------------------------------------------------------------------
6057       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6058
6059       use comm_sccalc
6060 !      implicit real*8 (a-h,o-z)
6061 !      include 'DIMENSIONS'
6062 !      include 'COMMON.GEO'
6063 !      include 'COMMON.LOCAL'
6064 !      include 'COMMON.IOUNITS'
6065 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6066       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6067       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6068       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6069       real(kind=8) :: escloci
6070       logical :: mixed
6071 !el local variables
6072       integer :: j,iii,l,k !el,it,nlobit
6073       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6074 !el       time11,time12,time112
6075 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6076         escloc_i=0.0D0
6077         do j=1,3
6078           dersc(j)=0.0D0
6079           if (mixed) ddersc(j)=0.0d0
6080         enddo
6081         x3=x(3)
6082
6083 ! Because of periodicity of the dependence of the SC energy in omega we have
6084 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6085 ! To avoid underflows, first compute & store the exponents.
6086
6087         do iii=-1,1
6088
6089           x(3)=x3+iii*dwapi
6090
6091           do j=1,nlobit
6092             do k=1,3
6093               z(k)=x(k)-censc(k,j,it)
6094             enddo
6095             do k=1,3
6096               Axk=0.0D0
6097               do l=1,3
6098                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6099               enddo
6100               Ax(k,j,iii)=Axk
6101             enddo
6102             expfac=0.0D0
6103             do k=1,3
6104               expfac=expfac+Ax(k,j,iii)*z(k)
6105             enddo
6106             contr(j,iii)=expfac
6107           enddo ! j
6108
6109         enddo ! iii
6110
6111         x(3)=x3
6112 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6113 ! subsequent NaNs and INFs in energy calculation.
6114 ! Find the largest exponent
6115         emin=contr(1,-1)
6116         do iii=-1,1
6117           do j=1,nlobit
6118             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6119           enddo
6120         enddo
6121         emin=0.5D0*emin
6122 !d      print *,'it=',it,' emin=',emin
6123
6124 ! Compute the contribution to SC energy and derivatives
6125         do iii=-1,1
6126
6127           do j=1,nlobit
6128 #ifdef OSF
6129             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6130             if(adexp.ne.adexp) adexp=1.0
6131             expfac=dexp(adexp)
6132 #else
6133             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6134 #endif
6135 !d          print *,'j=',j,' expfac=',expfac
6136             escloc_i=escloc_i+expfac
6137             do k=1,3
6138               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6139             enddo
6140             if (mixed) then
6141               do k=1,3,2
6142                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6143                   +gaussc(k,2,j,it))*expfac
6144               enddo
6145             endif
6146           enddo
6147
6148         enddo ! iii
6149
6150         dersc(1)=dersc(1)/cos(theti)**2
6151         ddersc(1)=ddersc(1)/cos(theti)**2
6152         ddersc(3)=ddersc(3)
6153
6154         escloci=-(dlog(escloc_i)-emin)
6155         do j=1,3
6156           dersc(j)=dersc(j)/escloc_i
6157         enddo
6158         if (mixed) then
6159           do j=1,3,2
6160             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6161           enddo
6162         endif
6163       return
6164       end subroutine enesc
6165 !-----------------------------------------------------------------------------
6166       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6167
6168       use comm_sccalc
6169 !      implicit real*8 (a-h,o-z)
6170 !      include 'DIMENSIONS'
6171 !      include 'COMMON.GEO'
6172 !      include 'COMMON.LOCAL'
6173 !      include 'COMMON.IOUNITS'
6174 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6175       real(kind=8),dimension(3) :: x,z,dersc
6176       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6177       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6178       real(kind=8) :: escloci,dersc12,emin
6179       logical :: mixed
6180 !el local varables
6181       integer :: j,k,l !el,it,nlobit
6182       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6183
6184       escloc_i=0.0D0
6185
6186       do j=1,3
6187         dersc(j)=0.0D0
6188       enddo
6189
6190       do j=1,nlobit
6191         do k=1,2
6192           z(k)=x(k)-censc(k,j,it)
6193         enddo
6194         z(3)=dwapi
6195         do k=1,3
6196           Axk=0.0D0
6197           do l=1,3
6198             Axk=Axk+gaussc(l,k,j,it)*z(l)
6199           enddo
6200           Ax(k,j)=Axk
6201         enddo
6202         expfac=0.0D0
6203         do k=1,3
6204           expfac=expfac+Ax(k,j)*z(k)
6205         enddo
6206         contr(j)=expfac
6207       enddo ! j
6208
6209 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6210 ! subsequent NaNs and INFs in energy calculation.
6211 ! Find the largest exponent
6212       emin=contr(1)
6213       do j=1,nlobit
6214         if (emin.gt.contr(j)) emin=contr(j)
6215       enddo
6216       emin=0.5D0*emin
6217
6218 ! Compute the contribution to SC energy and derivatives
6219
6220       dersc12=0.0d0
6221       do j=1,nlobit
6222         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6223         escloc_i=escloc_i+expfac
6224         do k=1,2
6225           dersc(k)=dersc(k)+Ax(k,j)*expfac
6226         enddo
6227         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6228                   +gaussc(1,2,j,it))*expfac
6229         dersc(3)=0.0d0
6230       enddo
6231
6232       dersc(1)=dersc(1)/cos(theti)**2
6233       dersc12=dersc12/cos(theti)**2
6234       escloci=-(dlog(escloc_i)-emin)
6235       do j=1,2
6236         dersc(j)=dersc(j)/escloc_i
6237       enddo
6238       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6239       return
6240       end subroutine enesc_bound
6241 #else
6242 !-----------------------------------------------------------------------------
6243       subroutine esc(escloc)
6244 ! Calculate the local energy of a side chain and its derivatives in the
6245 ! corresponding virtual-bond valence angles THETA and the spherical angles
6246 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6247 ! added by Urszula Kozlowska. 07/11/2007
6248 !
6249       use comm_sccalc
6250 !      implicit real*8 (a-h,o-z)
6251 !      include 'DIMENSIONS'
6252 !      include 'COMMON.GEO'
6253 !      include 'COMMON.LOCAL'
6254 !      include 'COMMON.VAR'
6255 !      include 'COMMON.SCROT'
6256 !      include 'COMMON.INTERACT'
6257 !      include 'COMMON.DERIV'
6258 !      include 'COMMON.CHAIN'
6259 !      include 'COMMON.IOUNITS'
6260 !      include 'COMMON.NAMES'
6261 !      include 'COMMON.FFIELD'
6262 !      include 'COMMON.CONTROL'
6263 !      include 'COMMON.VECTORS'
6264       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6265       real(kind=8),dimension(65) :: x
6266       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6267          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6268       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6269       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6270          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6271 !el local variables
6272       integer :: i,j,k !el,it,nlobit
6273       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6274 !el      real(kind=8) :: time11,time12,time112,theti
6275 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6276       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6277                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6278                    sumene1x,sumene2x,sumene3x,sumene4x,&
6279                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6280                    cosfac2xx,sinfac2yy
6281 #ifdef DEBUG
6282       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6283                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6284                    de_dt_num
6285 #endif
6286 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6287
6288       delta=0.02d0*pi
6289       escloc=0.0D0
6290       do i=loc_start,loc_end
6291         if (itype(i,1).eq.ntyp1) cycle
6292         costtab(i+1) =dcos(theta(i+1))
6293         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6294         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6295         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6296         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6297         cosfac=dsqrt(cosfac2)
6298         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6299         sinfac=dsqrt(sinfac2)
6300         it=iabs(itype(i,1))
6301         if (it.eq.10) goto 1
6302 !
6303 !  Compute the axes of tghe local cartesian coordinates system; store in
6304 !   x_prime, y_prime and z_prime
6305 !
6306         do j=1,3
6307           x_prime(j) = 0.00
6308           y_prime(j) = 0.00
6309           z_prime(j) = 0.00
6310         enddo
6311 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6312 !     &   dc_norm(3,i+nres)
6313         do j = 1,3
6314           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6315           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6316         enddo
6317         do j = 1,3
6318           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6319         enddo
6320 !       write (2,*) "i",i
6321 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6322 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6323 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6324 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6325 !      & " xy",scalar(x_prime(1),y_prime(1)),
6326 !      & " xz",scalar(x_prime(1),z_prime(1)),
6327 !      & " yy",scalar(y_prime(1),y_prime(1)),
6328 !      & " yz",scalar(y_prime(1),z_prime(1)),
6329 !      & " zz",scalar(z_prime(1),z_prime(1))
6330 !
6331 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6332 ! to local coordinate system. Store in xx, yy, zz.
6333 !
6334         xx=0.0d0
6335         yy=0.0d0
6336         zz=0.0d0
6337         do j = 1,3
6338           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6339           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6340           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6341         enddo
6342
6343         xxtab(i)=xx
6344         yytab(i)=yy
6345         zztab(i)=zz
6346 !
6347 ! Compute the energy of the ith side cbain
6348 !
6349 !        write (2,*) "xx",xx," yy",yy," zz",zz
6350         it=iabs(itype(i,1))
6351         do j = 1,65
6352           x(j) = sc_parmin(j,it)
6353         enddo
6354 #ifdef CHECK_COORD
6355 !c diagnostics - remove later
6356         xx1 = dcos(alph(2))
6357         yy1 = dsin(alph(2))*dcos(omeg(2))
6358         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6359         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6360           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6361           xx1,yy1,zz1
6362 !,"  --- ", xx_w,yy_w,zz_w
6363 ! end diagnostics
6364 #endif
6365         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6366          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6367          + x(10)*yy*zz
6368         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6369          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6370          + x(20)*yy*zz
6371         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6372          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6373          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6374          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6375          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6376          +x(40)*xx*yy*zz
6377         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6378          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6379          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6380          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6381          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6382          +x(60)*xx*yy*zz
6383         dsc_i   = 0.743d0+x(61)
6384         dp2_i   = 1.9d0+x(62)
6385         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6386                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6387         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6388                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6389         s1=(1+x(63))/(0.1d0 + dscp1)
6390         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6391         s2=(1+x(65))/(0.1d0 + dscp2)
6392         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6393         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6394       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6395 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6396 !     &   sumene4,
6397 !     &   dscp1,dscp2,sumene
6398 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6399         escloc = escloc + sumene
6400 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6401 !     & ,zz,xx,yy
6402 !#define DEBUG
6403 #ifdef DEBUG
6404 !
6405 ! This section to check the numerical derivatives of the energy of ith side
6406 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6407 ! #define DEBUG in the code to turn it on.
6408 !
6409         write (2,*) "sumene               =",sumene
6410         aincr=1.0d-7
6411         xxsave=xx
6412         xx=xx+aincr
6413         write (2,*) xx,yy,zz
6414         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6415         de_dxx_num=(sumenep-sumene)/aincr
6416         xx=xxsave
6417         write (2,*) "xx+ sumene from enesc=",sumenep
6418         yysave=yy
6419         yy=yy+aincr
6420         write (2,*) xx,yy,zz
6421         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6422         de_dyy_num=(sumenep-sumene)/aincr
6423         yy=yysave
6424         write (2,*) "yy+ sumene from enesc=",sumenep
6425         zzsave=zz
6426         zz=zz+aincr
6427         write (2,*) xx,yy,zz
6428         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6429         de_dzz_num=(sumenep-sumene)/aincr
6430         zz=zzsave
6431         write (2,*) "zz+ sumene from enesc=",sumenep
6432         costsave=cost2tab(i+1)
6433         sintsave=sint2tab(i+1)
6434         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6435         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6436         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6437         de_dt_num=(sumenep-sumene)/aincr
6438         write (2,*) " t+ sumene from enesc=",sumenep
6439         cost2tab(i+1)=costsave
6440         sint2tab(i+1)=sintsave
6441 ! End of diagnostics section.
6442 #endif
6443 !
6444 ! Compute the gradient of esc
6445 !
6446 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6447         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6448         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6449         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6450         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6451         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6452         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6453         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6454         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6455         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6456            *(pom_s1/dscp1+pom_s16*dscp1**4)
6457         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6458            *(pom_s2/dscp2+pom_s26*dscp2**4)
6459         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6460         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6461         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6462         +x(40)*yy*zz
6463         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6464         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6465         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6466         +x(60)*yy*zz
6467         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6468               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6469               +(pom1+pom2)*pom_dx
6470 #ifdef DEBUG
6471         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6472 #endif
6473 !
6474         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6475         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6476         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6477         +x(40)*xx*zz
6478         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6479         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6480         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6481         +x(59)*zz**2 +x(60)*xx*zz
6482         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6483               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6484               +(pom1-pom2)*pom_dy
6485 #ifdef DEBUG
6486         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6487 #endif
6488 !
6489         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6490         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6491         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6492         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6493         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6494         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6495         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6496         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6497 #ifdef DEBUG
6498         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6499 #endif
6500 !
6501         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6502         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6503         +pom1*pom_dt1+pom2*pom_dt2
6504 #ifdef DEBUG
6505         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6506 #endif
6507 !
6508 !
6509        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6510        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6511        cosfac2xx=cosfac2*xx
6512        sinfac2yy=sinfac2*yy
6513        do k = 1,3
6514          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6515             vbld_inv(i+1)
6516          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6517             vbld_inv(i)
6518          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6519          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6520 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6521 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6522 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6523 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6524          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6525          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6526          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6527          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6528          dZZ_Ci1(k)=0.0d0
6529          dZZ_Ci(k)=0.0d0
6530          do j=1,3
6531            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6532            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6533            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6534            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6535          enddo
6536
6537          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6538          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6539          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6540          (z_prime(k)-zz*dC_norm(k,i+nres))
6541 !
6542          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6543          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6544        enddo
6545
6546        do k=1,3
6547          dXX_Ctab(k,i)=dXX_Ci(k)
6548          dXX_C1tab(k,i)=dXX_Ci1(k)
6549          dYY_Ctab(k,i)=dYY_Ci(k)
6550          dYY_C1tab(k,i)=dYY_Ci1(k)
6551          dZZ_Ctab(k,i)=dZZ_Ci(k)
6552          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6553          dXX_XYZtab(k,i)=dXX_XYZ(k)
6554          dYY_XYZtab(k,i)=dYY_XYZ(k)
6555          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6556        enddo
6557
6558        do k = 1,3
6559 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6560 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6561 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6562 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6563 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6564 !     &    dt_dci(k)
6565 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6566 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6567          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6568           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6569          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6570           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6571          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6572           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6573        enddo
6574 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6575 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6576
6577 ! to check gradient call subroutine check_grad
6578
6579     1 continue
6580       enddo
6581       return
6582       end subroutine esc
6583 !-----------------------------------------------------------------------------
6584       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6585 !      implicit none
6586       real(kind=8),dimension(65) :: x
6587       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6588         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6589
6590       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6591         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6592         + x(10)*yy*zz
6593       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6594         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6595         + x(20)*yy*zz
6596       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6597         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6598         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6599         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6600         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6601         +x(40)*xx*yy*zz
6602       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6603         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6604         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6605         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6606         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6607         +x(60)*xx*yy*zz
6608       dsc_i   = 0.743d0+x(61)
6609       dp2_i   = 1.9d0+x(62)
6610       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6611                 *(xx*cost2+yy*sint2))
6612       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6613                 *(xx*cost2-yy*sint2))
6614       s1=(1+x(63))/(0.1d0 + dscp1)
6615       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6616       s2=(1+x(65))/(0.1d0 + dscp2)
6617       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6618       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6619        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6620       enesc=sumene
6621       return
6622       end function enesc
6623 #endif
6624 !-----------------------------------------------------------------------------
6625       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6626 !
6627 ! This procedure calculates two-body contact function g(rij) and its derivative:
6628 !
6629 !           eps0ij                                     !       x < -1
6630 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6631 !            0                                         !       x > 1
6632 !
6633 ! where x=(rij-r0ij)/delta
6634 !
6635 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6636 !
6637 !      implicit none
6638       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6639       real(kind=8) :: x,x2,x4,delta
6640 !     delta=0.02D0*r0ij
6641 !      delta=0.2D0*r0ij
6642       x=(rij-r0ij)/delta
6643       if (x.lt.-1.0D0) then
6644         fcont=eps0ij
6645         fprimcont=0.0D0
6646       else if (x.le.1.0D0) then
6647         x2=x*x
6648         x4=x2*x2
6649         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6650         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6651       else
6652         fcont=0.0D0
6653         fprimcont=0.0D0
6654       endif
6655       return
6656       end subroutine gcont
6657 !-----------------------------------------------------------------------------
6658       subroutine splinthet(theti,delta,ss,ssder)
6659 !      implicit real*8 (a-h,o-z)
6660 !      include 'DIMENSIONS'
6661 !      include 'COMMON.VAR'
6662 !      include 'COMMON.GEO'
6663       real(kind=8) :: theti,delta,ss,ssder
6664       real(kind=8) :: thetup,thetlow
6665       thetup=pi-delta
6666       thetlow=delta
6667       if (theti.gt.pipol) then
6668         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6669       else
6670         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6671         ssder=-ssder
6672       endif
6673       return
6674       end subroutine splinthet
6675 !-----------------------------------------------------------------------------
6676       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6677 !      implicit none
6678       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6679       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6680       a1=fprim0*delta/(f1-f0)
6681       a2=3.0d0-2.0d0*a1
6682       a3=a1-2.0d0
6683       ksi=(x-x0)/delta
6684       ksi2=ksi*ksi
6685       ksi3=ksi2*ksi
6686       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6687       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6688       return
6689       end subroutine spline1
6690 !-----------------------------------------------------------------------------
6691       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6692 !      implicit none
6693       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6694       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6695       ksi=(x-x0)/delta
6696       ksi2=ksi*ksi
6697       ksi3=ksi2*ksi
6698       a1=fprim0x*delta
6699       a2=3*(f1x-f0x)-2*fprim0x*delta
6700       a3=fprim0x*delta-2*(f1x-f0x)
6701       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6702       return
6703       end subroutine spline2
6704 !-----------------------------------------------------------------------------
6705 #ifdef CRYST_TOR
6706 !-----------------------------------------------------------------------------
6707       subroutine etor(etors,edihcnstr)
6708 !      implicit real*8 (a-h,o-z)
6709 !      include 'DIMENSIONS'
6710 !      include 'COMMON.VAR'
6711 !      include 'COMMON.GEO'
6712 !      include 'COMMON.LOCAL'
6713 !      include 'COMMON.TORSION'
6714 !      include 'COMMON.INTERACT'
6715 !      include 'COMMON.DERIV'
6716 !      include 'COMMON.CHAIN'
6717 !      include 'COMMON.NAMES'
6718 !      include 'COMMON.IOUNITS'
6719 !      include 'COMMON.FFIELD'
6720 !      include 'COMMON.TORCNSTR'
6721 !      include 'COMMON.CONTROL'
6722       real(kind=8) :: etors,edihcnstr
6723       logical :: lprn
6724 !el local variables
6725       integer :: i,j,
6726       real(kind=8) :: phii,fac,etors_ii
6727
6728 ! Set lprn=.true. for debugging
6729       lprn=.false.
6730 !      lprn=.true.
6731       etors=0.0D0
6732       do i=iphi_start,iphi_end
6733       etors_ii=0.0D0
6734         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6735             .or. itype(i,1).eq.ntyp1) cycle
6736         itori=itortyp(itype(i-2,1))
6737         itori1=itortyp(itype(i-1,1))
6738         phii=phi(i)
6739         gloci=0.0D0
6740 ! Proline-Proline pair is a special case...
6741         if (itori.eq.3 .and. itori1.eq.3) then
6742           if (phii.gt.-dwapi3) then
6743             cosphi=dcos(3*phii)
6744             fac=1.0D0/(1.0D0-cosphi)
6745             etorsi=v1(1,3,3)*fac
6746             etorsi=etorsi+etorsi
6747             etors=etors+etorsi-v1(1,3,3)
6748             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6749             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6750           endif
6751           do j=1,3
6752             v1ij=v1(j+1,itori,itori1)
6753             v2ij=v2(j+1,itori,itori1)
6754             cosphi=dcos(j*phii)
6755             sinphi=dsin(j*phii)
6756             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6757             if (energy_dec) etors_ii=etors_ii+ &
6758                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6759             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6760           enddo
6761         else
6762           do j=1,nterm_old
6763             v1ij=v1(j,itori,itori1)
6764             v2ij=v2(j,itori,itori1)
6765             cosphi=dcos(j*phii)
6766             sinphi=dsin(j*phii)
6767             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6768             if (energy_dec) etors_ii=etors_ii+ &
6769                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6770             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6771           enddo
6772         endif
6773         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6774              'etor',i,etors_ii
6775         if (lprn) &
6776         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6777         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6778         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6779         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6780 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6781       enddo
6782 ! 6/20/98 - dihedral angle constraints
6783       edihcnstr=0.0d0
6784       do i=1,ndih_constr
6785         itori=idih_constr(i)
6786         phii=phi(itori)
6787         difi=phii-phi0(i)
6788         if (difi.gt.drange(i)) then
6789           difi=difi-drange(i)
6790           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6791           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6792         else if (difi.lt.-drange(i)) then
6793           difi=difi+drange(i)
6794           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6795           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6796         endif
6797 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6798 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6799       enddo
6800 !      write (iout,*) 'edihcnstr',edihcnstr
6801       return
6802       end subroutine etor
6803 !-----------------------------------------------------------------------------
6804       subroutine etor_d(etors_d)
6805       real(kind=8) :: etors_d
6806       etors_d=0.0d0
6807       return
6808       end subroutine etor_d
6809 #else
6810 !-----------------------------------------------------------------------------
6811       subroutine etor(etors,edihcnstr)
6812 !      implicit real*8 (a-h,o-z)
6813 !      include 'DIMENSIONS'
6814 !      include 'COMMON.VAR'
6815 !      include 'COMMON.GEO'
6816 !      include 'COMMON.LOCAL'
6817 !      include 'COMMON.TORSION'
6818 !      include 'COMMON.INTERACT'
6819 !      include 'COMMON.DERIV'
6820 !      include 'COMMON.CHAIN'
6821 !      include 'COMMON.NAMES'
6822 !      include 'COMMON.IOUNITS'
6823 !      include 'COMMON.FFIELD'
6824 !      include 'COMMON.TORCNSTR'
6825 !      include 'COMMON.CONTROL'
6826       real(kind=8) :: etors,edihcnstr
6827       logical :: lprn
6828 !el local variables
6829       integer :: i,j,iblock,itori,itori1
6830       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6831                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6832 ! Set lprn=.true. for debugging
6833       lprn=.false.
6834 !     lprn=.true.
6835       etors=0.0D0
6836       do i=iphi_start,iphi_end
6837         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6838              .or. itype(i-3,1).eq.ntyp1 &
6839              .or. itype(i,1).eq.ntyp1) cycle
6840         etors_ii=0.0D0
6841          if (iabs(itype(i,1)).eq.20) then
6842          iblock=2
6843          else
6844          iblock=1
6845          endif
6846         itori=itortyp(itype(i-2,1))
6847         itori1=itortyp(itype(i-1,1))
6848         phii=phi(i)
6849         gloci=0.0D0
6850 ! Regular cosine and sine terms
6851         do j=1,nterm(itori,itori1,iblock)
6852           v1ij=v1(j,itori,itori1,iblock)
6853           v2ij=v2(j,itori,itori1,iblock)
6854           cosphi=dcos(j*phii)
6855           sinphi=dsin(j*phii)
6856           etors=etors+v1ij*cosphi+v2ij*sinphi
6857           if (energy_dec) etors_ii=etors_ii+ &
6858                      v1ij*cosphi+v2ij*sinphi
6859           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6860         enddo
6861 ! Lorentz terms
6862 !                         v1
6863 !  E = SUM ----------------------------------- - v1
6864 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6865 !
6866         cosphi=dcos(0.5d0*phii)
6867         sinphi=dsin(0.5d0*phii)
6868         do j=1,nlor(itori,itori1,iblock)
6869           vl1ij=vlor1(j,itori,itori1)
6870           vl2ij=vlor2(j,itori,itori1)
6871           vl3ij=vlor3(j,itori,itori1)
6872           pom=vl2ij*cosphi+vl3ij*sinphi
6873           pom1=1.0d0/(pom*pom+1.0d0)
6874           etors=etors+vl1ij*pom1
6875           if (energy_dec) etors_ii=etors_ii+ &
6876                      vl1ij*pom1
6877           pom=-pom*pom1*pom1
6878           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6879         enddo
6880 ! Subtract the constant term
6881         etors=etors-v0(itori,itori1,iblock)
6882           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6883                'etor',i,etors_ii-v0(itori,itori1,iblock)
6884         if (lprn) &
6885         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6886         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6887         (v1(j,itori,itori1,iblock),j=1,6),&
6888         (v2(j,itori,itori1,iblock),j=1,6)
6889         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6890 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6891       enddo
6892 ! 6/20/98 - dihedral angle constraints
6893       edihcnstr=0.0d0
6894 !      do i=1,ndih_constr
6895       do i=idihconstr_start,idihconstr_end
6896         itori=idih_constr(i)
6897         phii=phi(itori)
6898         difi=pinorm(phii-phi0(i))
6899         if (difi.gt.drange(i)) then
6900           difi=difi-drange(i)
6901           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6902           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6903         else if (difi.lt.-drange(i)) then
6904           difi=difi+drange(i)
6905           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6906           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6907         else
6908           difi=0.0
6909         endif
6910 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6911 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6912 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6913       enddo
6914 !d       write (iout,*) 'edihcnstr',edihcnstr
6915       return
6916       end subroutine etor
6917 !-----------------------------------------------------------------------------
6918       subroutine etor_d(etors_d)
6919 ! 6/23/01 Compute double torsional energy
6920 !      implicit real*8 (a-h,o-z)
6921 !      include 'DIMENSIONS'
6922 !      include 'COMMON.VAR'
6923 !      include 'COMMON.GEO'
6924 !      include 'COMMON.LOCAL'
6925 !      include 'COMMON.TORSION'
6926 !      include 'COMMON.INTERACT'
6927 !      include 'COMMON.DERIV'
6928 !      include 'COMMON.CHAIN'
6929 !      include 'COMMON.NAMES'
6930 !      include 'COMMON.IOUNITS'
6931 !      include 'COMMON.FFIELD'
6932 !      include 'COMMON.TORCNSTR'
6933       real(kind=8) :: etors_d,etors_d_ii
6934       logical :: lprn
6935 !el local variables
6936       integer :: i,j,k,l,itori,itori1,itori2,iblock
6937       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6938                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6939                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6940                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6941 ! Set lprn=.true. for debugging
6942       lprn=.false.
6943 !     lprn=.true.
6944       etors_d=0.0D0
6945 !      write(iout,*) "a tu??"
6946       do i=iphid_start,iphid_end
6947         etors_d_ii=0.0D0
6948         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6949             .or. itype(i-3,1).eq.ntyp1 &
6950             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6951         itori=itortyp(itype(i-2,1))
6952         itori1=itortyp(itype(i-1,1))
6953         itori2=itortyp(itype(i,1))
6954         phii=phi(i)
6955         phii1=phi(i+1)
6956         gloci1=0.0D0
6957         gloci2=0.0D0
6958         iblock=1
6959         if (iabs(itype(i+1,1)).eq.20) iblock=2
6960
6961 ! Regular cosine and sine terms
6962         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6963           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6964           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6965           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6966           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6967           cosphi1=dcos(j*phii)
6968           sinphi1=dsin(j*phii)
6969           cosphi2=dcos(j*phii1)
6970           sinphi2=dsin(j*phii1)
6971           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6972            v2cij*cosphi2+v2sij*sinphi2
6973           if (energy_dec) etors_d_ii=etors_d_ii+ &
6974            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6975           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6976           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6977         enddo
6978         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6979           do l=1,k-1
6980             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6981             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6982             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6983             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6984             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6985             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6986             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6987             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6988             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6989               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6990             if (energy_dec) etors_d_ii=etors_d_ii+ &
6991               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6992               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6993             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6994               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6995             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6996               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6997           enddo
6998         enddo
6999         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7000                             'etor_d',i,etors_d_ii
7001         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7002         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7003       enddo
7004       return
7005       end subroutine etor_d
7006 #endif
7007 !-----------------------------------------------------------------------------
7008       subroutine eback_sc_corr(esccor)
7009 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7010 !        conformational states; temporarily implemented as differences
7011 !        between UNRES torsional potentials (dependent on three types of
7012 !        residues) and the torsional potentials dependent on all 20 types
7013 !        of residues computed from AM1  energy surfaces of terminally-blocked
7014 !        amino-acid residues.
7015 !      implicit real*8 (a-h,o-z)
7016 !      include 'DIMENSIONS'
7017 !      include 'COMMON.VAR'
7018 !      include 'COMMON.GEO'
7019 !      include 'COMMON.LOCAL'
7020 !      include 'COMMON.TORSION'
7021 !      include 'COMMON.SCCOR'
7022 !      include 'COMMON.INTERACT'
7023 !      include 'COMMON.DERIV'
7024 !      include 'COMMON.CHAIN'
7025 !      include 'COMMON.NAMES'
7026 !      include 'COMMON.IOUNITS'
7027 !      include 'COMMON.FFIELD'
7028 !      include 'COMMON.CONTROL'
7029       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7030                    cosphi,sinphi
7031       logical :: lprn
7032       integer :: i,interty,j,isccori,isccori1,intertyp
7033 ! Set lprn=.true. for debugging
7034       lprn=.false.
7035 !      lprn=.true.
7036 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7037       esccor=0.0D0
7038       do i=itau_start,itau_end
7039         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7040         esccor_ii=0.0D0
7041         isccori=isccortyp(itype(i-2,1))
7042         isccori1=isccortyp(itype(i-1,1))
7043
7044 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7045         phii=phi(i)
7046         do intertyp=1,3 !intertyp
7047          esccor_ii=0.0D0
7048 !c Added 09 May 2012 (Adasko)
7049 !c  Intertyp means interaction type of backbone mainchain correlation:
7050 !   1 = SC...Ca...Ca...Ca
7051 !   2 = Ca...Ca...Ca...SC
7052 !   3 = SC...Ca...Ca...SCi
7053         gloci=0.0D0
7054         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7055             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7056             (itype(i-1,1).eq.ntyp1))) &
7057           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7058            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7059            .or.(itype(i,1).eq.ntyp1))) &
7060           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7061             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7062             (itype(i-3,1).eq.ntyp1)))) cycle
7063         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7064         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7065        cycle
7066        do j=1,nterm_sccor(isccori,isccori1)
7067           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7068           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7069           cosphi=dcos(j*tauangle(intertyp,i))
7070           sinphi=dsin(j*tauangle(intertyp,i))
7071           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7072           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7073           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7074         enddo
7075         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7076                                 'esccor',i,intertyp,esccor_ii
7077 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7078         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7079         if (lprn) &
7080         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7081         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7082         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7083         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7084         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7085        enddo !intertyp
7086       enddo
7087
7088       return
7089       end subroutine eback_sc_corr
7090 !-----------------------------------------------------------------------------
7091       subroutine multibody(ecorr)
7092 ! This subroutine calculates multi-body contributions to energy following
7093 ! the idea of Skolnick et al. If side chains I and J make a contact and
7094 ! at the same time side chains I+1 and J+1 make a contact, an extra
7095 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7096 !      implicit real*8 (a-h,o-z)
7097 !      include 'DIMENSIONS'
7098 !      include 'COMMON.IOUNITS'
7099 !      include 'COMMON.DERIV'
7100 !      include 'COMMON.INTERACT'
7101 !      include 'COMMON.CONTACTS'
7102       real(kind=8),dimension(3) :: gx,gx1
7103       logical :: lprn
7104       real(kind=8) :: ecorr
7105       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7106 ! Set lprn=.true. for debugging
7107       lprn=.false.
7108
7109       if (lprn) then
7110         write (iout,'(a)') 'Contact function values:'
7111         do i=nnt,nct-2
7112           write (iout,'(i2,20(1x,i2,f10.5))') &
7113               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7114         enddo
7115       endif
7116       ecorr=0.0D0
7117
7118 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7119 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7120       do i=nnt,nct
7121         do j=1,3
7122           gradcorr(j,i)=0.0D0
7123           gradxorr(j,i)=0.0D0
7124         enddo
7125       enddo
7126       do i=nnt,nct-2
7127
7128         DO ISHIFT = 3,4
7129
7130         i1=i+ishift
7131         num_conti=num_cont(i)
7132         num_conti1=num_cont(i1)
7133         do jj=1,num_conti
7134           j=jcont(jj,i)
7135           do kk=1,num_conti1
7136             j1=jcont(kk,i1)
7137             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7138 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7139 !d   &                   ' ishift=',ishift
7140 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7141 ! The system gains extra energy.
7142               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7143             endif   ! j1==j+-ishift
7144           enddo     ! kk
7145         enddo       ! jj
7146
7147         ENDDO ! ISHIFT
7148
7149       enddo         ! i
7150       return
7151       end subroutine multibody
7152 !-----------------------------------------------------------------------------
7153       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7154 !      implicit real*8 (a-h,o-z)
7155 !      include 'DIMENSIONS'
7156 !      include 'COMMON.IOUNITS'
7157 !      include 'COMMON.DERIV'
7158 !      include 'COMMON.INTERACT'
7159 !      include 'COMMON.CONTACTS'
7160       real(kind=8),dimension(3) :: gx,gx1
7161       logical :: lprn
7162       integer :: i,j,k,l,jj,kk,m,ll
7163       real(kind=8) :: eij,ekl
7164       lprn=.false.
7165       eij=facont(jj,i)
7166       ekl=facont(kk,k)
7167 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7168 ! Calculate the multi-body contribution to energy.
7169 ! Calculate multi-body contributions to the gradient.
7170 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7171 !d   & k,l,(gacont(m,kk,k),m=1,3)
7172       do m=1,3
7173         gx(m) =ekl*gacont(m,jj,i)
7174         gx1(m)=eij*gacont(m,kk,k)
7175         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7176         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7177         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7178         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7179       enddo
7180       do m=i,j-1
7181         do ll=1,3
7182           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7183         enddo
7184       enddo
7185       do m=k,l-1
7186         do ll=1,3
7187           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7188         enddo
7189       enddo
7190       esccorr=-eij*ekl
7191       return
7192       end function esccorr
7193 !-----------------------------------------------------------------------------
7194       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7195 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7196 !      implicit real*8 (a-h,o-z)
7197 !      include 'DIMENSIONS'
7198 !      include 'COMMON.IOUNITS'
7199 #ifdef MPI
7200       include "mpif.h"
7201 !      integer :: maxconts !max_cont=maxconts  =nres/4
7202       integer,parameter :: max_dim=26
7203       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7204       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7205 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7206 !el      common /przechowalnia/ zapas
7207       integer :: status(MPI_STATUS_SIZE)
7208       integer,dimension((nres/4)*2) :: req !maxconts*2
7209       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7210 #endif
7211 !      include 'COMMON.SETUP'
7212 !      include 'COMMON.FFIELD'
7213 !      include 'COMMON.DERIV'
7214 !      include 'COMMON.INTERACT'
7215 !      include 'COMMON.CONTACTS'
7216 !      include 'COMMON.CONTROL'
7217 !      include 'COMMON.LOCAL'
7218       real(kind=8),dimension(3) :: gx,gx1
7219       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7220       logical :: lprn,ldone
7221 !el local variables
7222       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7223               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7224
7225 ! Set lprn=.true. for debugging
7226       lprn=.false.
7227 #ifdef MPI
7228 !      maxconts=nres/4
7229       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7230       n_corr=0
7231       n_corr1=0
7232       if (nfgtasks.le.1) goto 30
7233       if (lprn) then
7234         write (iout,'(a)') 'Contact function values before RECEIVE:'
7235         do i=nnt,nct-2
7236           write (iout,'(2i3,50(1x,i2,f5.2))') &
7237           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7238           j=1,num_cont_hb(i))
7239         enddo
7240       endif
7241       call flush(iout)
7242       do i=1,ntask_cont_from
7243         ncont_recv(i)=0
7244       enddo
7245       do i=1,ntask_cont_to
7246         ncont_sent(i)=0
7247       enddo
7248 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7249 !     & ntask_cont_to
7250 ! Make the list of contacts to send to send to other procesors
7251 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7252 !      call flush(iout)
7253       do i=iturn3_start,iturn3_end
7254 !        write (iout,*) "make contact list turn3",i," num_cont",
7255 !     &    num_cont_hb(i)
7256         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7257       enddo
7258       do i=iturn4_start,iturn4_end
7259 !        write (iout,*) "make contact list turn4",i," num_cont",
7260 !     &   num_cont_hb(i)
7261         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7262       enddo
7263       do ii=1,nat_sent
7264         i=iat_sent(ii)
7265 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7266 !     &    num_cont_hb(i)
7267         do j=1,num_cont_hb(i)
7268         do k=1,4
7269           jjc=jcont_hb(j,i)
7270           iproc=iint_sent_local(k,jjc,ii)
7271 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7272           if (iproc.gt.0) then
7273             ncont_sent(iproc)=ncont_sent(iproc)+1
7274             nn=ncont_sent(iproc)
7275             zapas(1,nn,iproc)=i
7276             zapas(2,nn,iproc)=jjc
7277             zapas(3,nn,iproc)=facont_hb(j,i)
7278             zapas(4,nn,iproc)=ees0p(j,i)
7279             zapas(5,nn,iproc)=ees0m(j,i)
7280             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7281             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7282             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7283             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7284             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7285             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7286             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7287             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7288             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7289             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7290             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7291             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7292             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7293             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7294             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7295             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7296             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7297             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7298             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7299             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7300             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7301           endif
7302         enddo
7303         enddo
7304       enddo
7305       if (lprn) then
7306       write (iout,*) &
7307         "Numbers of contacts to be sent to other processors",&
7308         (ncont_sent(i),i=1,ntask_cont_to)
7309       write (iout,*) "Contacts sent"
7310       do ii=1,ntask_cont_to
7311         nn=ncont_sent(ii)
7312         iproc=itask_cont_to(ii)
7313         write (iout,*) nn," contacts to processor",iproc,&
7314          " of CONT_TO_COMM group"
7315         do i=1,nn
7316           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7317         enddo
7318       enddo
7319       call flush(iout)
7320       endif
7321       CorrelType=477
7322       CorrelID=fg_rank+1
7323       CorrelType1=478
7324       CorrelID1=nfgtasks+fg_rank+1
7325       ireq=0
7326 ! Receive the numbers of needed contacts from other processors
7327       do ii=1,ntask_cont_from
7328         iproc=itask_cont_from(ii)
7329         ireq=ireq+1
7330         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7331           FG_COMM,req(ireq),IERR)
7332       enddo
7333 !      write (iout,*) "IRECV ended"
7334 !      call flush(iout)
7335 ! Send the number of contacts needed by other processors
7336       do ii=1,ntask_cont_to
7337         iproc=itask_cont_to(ii)
7338         ireq=ireq+1
7339         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7340           FG_COMM,req(ireq),IERR)
7341       enddo
7342 !      write (iout,*) "ISEND ended"
7343 !      write (iout,*) "number of requests (nn)",ireq
7344       call flush(iout)
7345       if (ireq.gt.0) &
7346         call MPI_Waitall(ireq,req,status_array,ierr)
7347 !      write (iout,*)
7348 !     &  "Numbers of contacts to be received from other processors",
7349 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7350 !      call flush(iout)
7351 ! Receive contacts
7352       ireq=0
7353       do ii=1,ntask_cont_from
7354         iproc=itask_cont_from(ii)
7355         nn=ncont_recv(ii)
7356 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7357 !     &   " of CONT_TO_COMM group"
7358         call flush(iout)
7359         if (nn.gt.0) then
7360           ireq=ireq+1
7361           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7362           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7363 !          write (iout,*) "ireq,req",ireq,req(ireq)
7364         endif
7365       enddo
7366 ! Send the contacts to processors that need them
7367       do ii=1,ntask_cont_to
7368         iproc=itask_cont_to(ii)
7369         nn=ncont_sent(ii)
7370 !        write (iout,*) nn," contacts to processor",iproc,
7371 !     &   " of CONT_TO_COMM group"
7372         if (nn.gt.0) then
7373           ireq=ireq+1
7374           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7375             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7376 !          write (iout,*) "ireq,req",ireq,req(ireq)
7377 !          do i=1,nn
7378 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7379 !          enddo
7380         endif
7381       enddo
7382 !      write (iout,*) "number of requests (contacts)",ireq
7383 !      write (iout,*) "req",(req(i),i=1,4)
7384 !      call flush(iout)
7385       if (ireq.gt.0) &
7386        call MPI_Waitall(ireq,req,status_array,ierr)
7387       do iii=1,ntask_cont_from
7388         iproc=itask_cont_from(iii)
7389         nn=ncont_recv(iii)
7390         if (lprn) then
7391         write (iout,*) "Received",nn," contacts from processor",iproc,&
7392          " of CONT_FROM_COMM group"
7393         call flush(iout)
7394         do i=1,nn
7395           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7396         enddo
7397         call flush(iout)
7398         endif
7399         do i=1,nn
7400           ii=zapas_recv(1,i,iii)
7401 ! Flag the received contacts to prevent double-counting
7402           jj=-zapas_recv(2,i,iii)
7403 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7404 !          call flush(iout)
7405           nnn=num_cont_hb(ii)+1
7406           num_cont_hb(ii)=nnn
7407           jcont_hb(nnn,ii)=jj
7408           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7409           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7410           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7411           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7412           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7413           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7414           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7415           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7416           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7417           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7418           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7419           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7420           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7421           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7422           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7423           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7424           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7425           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7426           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7427           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7428           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7429           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7430           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7431           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7432         enddo
7433       enddo
7434       call flush(iout)
7435       if (lprn) then
7436         write (iout,'(a)') 'Contact function values after receive:'
7437         do i=nnt,nct-2
7438           write (iout,'(2i3,50(1x,i3,f5.2))') &
7439           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7440           j=1,num_cont_hb(i))
7441         enddo
7442         call flush(iout)
7443       endif
7444    30 continue
7445 #endif
7446       if (lprn) then
7447         write (iout,'(a)') 'Contact function values:'
7448         do i=nnt,nct-2
7449           write (iout,'(2i3,50(1x,i3,f5.2))') &
7450           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7451           j=1,num_cont_hb(i))
7452         enddo
7453       endif
7454       ecorr=0.0D0
7455
7456 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7457 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7458 ! Remove the loop below after debugging !!!
7459       do i=nnt,nct
7460         do j=1,3
7461           gradcorr(j,i)=0.0D0
7462           gradxorr(j,i)=0.0D0
7463         enddo
7464       enddo
7465 ! Calculate the local-electrostatic correlation terms
7466       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7467         i1=i+1
7468         num_conti=num_cont_hb(i)
7469         num_conti1=num_cont_hb(i+1)
7470         do jj=1,num_conti
7471           j=jcont_hb(jj,i)
7472           jp=iabs(j)
7473           do kk=1,num_conti1
7474             j1=jcont_hb(kk,i1)
7475             jp1=iabs(j1)
7476 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7477 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7478             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7479                 .or. j.lt.0 .and. j1.gt.0) .and. &
7480                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7481 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7482 ! The system gains extra energy.
7483               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7484               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7485                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7486               n_corr=n_corr+1
7487             else if (j1.eq.j) then
7488 ! Contacts I-J and I-(J+1) occur simultaneously.
7489 ! The system loses extra energy.
7490 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7491             endif
7492           enddo ! kk
7493           do kk=1,num_conti
7494             j1=jcont_hb(kk,i)
7495 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7496 !    &         ' jj=',jj,' kk=',kk
7497             if (j1.eq.j+1) then
7498 ! Contacts I-J and (I+1)-J occur simultaneously.
7499 ! The system loses extra energy.
7500 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7501             endif ! j1==j+1
7502           enddo ! kk
7503         enddo ! jj
7504       enddo ! i
7505       return
7506       end subroutine multibody_hb
7507 !-----------------------------------------------------------------------------
7508       subroutine add_hb_contact(ii,jj,itask)
7509 !      implicit real*8 (a-h,o-z)
7510 !      include "DIMENSIONS"
7511 !      include "COMMON.IOUNITS"
7512 !      include "COMMON.CONTACTS"
7513 !      integer,parameter :: maxconts=nres/4
7514       integer,parameter :: max_dim=26
7515       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7516 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7517 !      common /przechowalnia/ zapas
7518       integer :: i,j,ii,jj,iproc,nn,jjc
7519       integer,dimension(4) :: itask
7520 !      write (iout,*) "itask",itask
7521       do i=1,2
7522         iproc=itask(i)
7523         if (iproc.gt.0) then
7524           do j=1,num_cont_hb(ii)
7525             jjc=jcont_hb(j,ii)
7526 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7527             if (jjc.eq.jj) then
7528               ncont_sent(iproc)=ncont_sent(iproc)+1
7529               nn=ncont_sent(iproc)
7530               zapas(1,nn,iproc)=ii
7531               zapas(2,nn,iproc)=jjc
7532               zapas(3,nn,iproc)=facont_hb(j,ii)
7533               zapas(4,nn,iproc)=ees0p(j,ii)
7534               zapas(5,nn,iproc)=ees0m(j,ii)
7535               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7536               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7537               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7538               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7539               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7540               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7541               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7542               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7543               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7544               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7545               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7546               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7547               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7548               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7549               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7550               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7551               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7552               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7553               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7554               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7555               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7556               exit
7557             endif
7558           enddo
7559         endif
7560       enddo
7561       return
7562       end subroutine add_hb_contact
7563 !-----------------------------------------------------------------------------
7564       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7565 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7566 !      implicit real*8 (a-h,o-z)
7567 !      include 'DIMENSIONS'
7568 !      include 'COMMON.IOUNITS'
7569       integer,parameter :: max_dim=70
7570 #ifdef MPI
7571       include "mpif.h"
7572 !      integer :: maxconts !max_cont=maxconts=nres/4
7573       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7574       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7575 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7576 !      common /przechowalnia/ zapas
7577       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7578         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7579         ierr,iii,nnn
7580 #endif
7581 !      include 'COMMON.SETUP'
7582 !      include 'COMMON.FFIELD'
7583 !      include 'COMMON.DERIV'
7584 !      include 'COMMON.LOCAL'
7585 !      include 'COMMON.INTERACT'
7586 !      include 'COMMON.CONTACTS'
7587 !      include 'COMMON.CHAIN'
7588 !      include 'COMMON.CONTROL'
7589       real(kind=8),dimension(3) :: gx,gx1
7590       integer,dimension(nres) :: num_cont_hb_old
7591       logical :: lprn,ldone
7592 !EL      double precision eello4,eello5,eelo6,eello_turn6
7593 !EL      external eello4,eello5,eello6,eello_turn6
7594 !el local variables
7595       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7596               j1,jp1,i1,num_conti1
7597       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7598       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7599
7600 ! Set lprn=.true. for debugging
7601       lprn=.false.
7602       eturn6=0.0d0
7603 #ifdef MPI
7604 !      maxconts=nres/4
7605       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7606       do i=1,nres
7607         num_cont_hb_old(i)=num_cont_hb(i)
7608       enddo
7609       n_corr=0
7610       n_corr1=0
7611       if (nfgtasks.le.1) goto 30
7612       if (lprn) then
7613         write (iout,'(a)') 'Contact function values before RECEIVE:'
7614         do i=nnt,nct-2
7615           write (iout,'(2i3,50(1x,i2,f5.2))') &
7616           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7617           j=1,num_cont_hb(i))
7618         enddo
7619       endif
7620       call flush(iout)
7621       do i=1,ntask_cont_from
7622         ncont_recv(i)=0
7623       enddo
7624       do i=1,ntask_cont_to
7625         ncont_sent(i)=0
7626       enddo
7627 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7628 !     & ntask_cont_to
7629 ! Make the list of contacts to send to send to other procesors
7630       do i=iturn3_start,iturn3_end
7631 !        write (iout,*) "make contact list turn3",i," num_cont",
7632 !     &    num_cont_hb(i)
7633         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7634       enddo
7635       do i=iturn4_start,iturn4_end
7636 !        write (iout,*) "make contact list turn4",i," num_cont",
7637 !     &   num_cont_hb(i)
7638         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7639       enddo
7640       do ii=1,nat_sent
7641         i=iat_sent(ii)
7642 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7643 !     &    num_cont_hb(i)
7644         do j=1,num_cont_hb(i)
7645         do k=1,4
7646           jjc=jcont_hb(j,i)
7647           iproc=iint_sent_local(k,jjc,ii)
7648 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7649           if (iproc.ne.0) then
7650             ncont_sent(iproc)=ncont_sent(iproc)+1
7651             nn=ncont_sent(iproc)
7652             zapas(1,nn,iproc)=i
7653             zapas(2,nn,iproc)=jjc
7654             zapas(3,nn,iproc)=d_cont(j,i)
7655             ind=3
7656             do kk=1,3
7657               ind=ind+1
7658               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7659             enddo
7660             do kk=1,2
7661               do ll=1,2
7662                 ind=ind+1
7663                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7664               enddo
7665             enddo
7666             do jj=1,5
7667               do kk=1,3
7668                 do ll=1,2
7669                   do mm=1,2
7670                     ind=ind+1
7671                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7672                   enddo
7673                 enddo
7674               enddo
7675             enddo
7676           endif
7677         enddo
7678         enddo
7679       enddo
7680       if (lprn) then
7681       write (iout,*) &
7682         "Numbers of contacts to be sent to other processors",&
7683         (ncont_sent(i),i=1,ntask_cont_to)
7684       write (iout,*) "Contacts sent"
7685       do ii=1,ntask_cont_to
7686         nn=ncont_sent(ii)
7687         iproc=itask_cont_to(ii)
7688         write (iout,*) nn," contacts to processor",iproc,&
7689          " of CONT_TO_COMM group"
7690         do i=1,nn
7691           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7692         enddo
7693       enddo
7694       call flush(iout)
7695       endif
7696       CorrelType=477
7697       CorrelID=fg_rank+1
7698       CorrelType1=478
7699       CorrelID1=nfgtasks+fg_rank+1
7700       ireq=0
7701 ! Receive the numbers of needed contacts from other processors
7702       do ii=1,ntask_cont_from
7703         iproc=itask_cont_from(ii)
7704         ireq=ireq+1
7705         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7706           FG_COMM,req(ireq),IERR)
7707       enddo
7708 !      write (iout,*) "IRECV ended"
7709 !      call flush(iout)
7710 ! Send the number of contacts needed by other processors
7711       do ii=1,ntask_cont_to
7712         iproc=itask_cont_to(ii)
7713         ireq=ireq+1
7714         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7715           FG_COMM,req(ireq),IERR)
7716       enddo
7717 !      write (iout,*) "ISEND ended"
7718 !      write (iout,*) "number of requests (nn)",ireq
7719       call flush(iout)
7720       if (ireq.gt.0) &
7721         call MPI_Waitall(ireq,req,status_array,ierr)
7722 !      write (iout,*)
7723 !     &  "Numbers of contacts to be received from other processors",
7724 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7725 !      call flush(iout)
7726 ! Receive contacts
7727       ireq=0
7728       do ii=1,ntask_cont_from
7729         iproc=itask_cont_from(ii)
7730         nn=ncont_recv(ii)
7731 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7732 !     &   " of CONT_TO_COMM group"
7733         call flush(iout)
7734         if (nn.gt.0) then
7735           ireq=ireq+1
7736           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7737           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7738 !          write (iout,*) "ireq,req",ireq,req(ireq)
7739         endif
7740       enddo
7741 ! Send the contacts to processors that need them
7742       do ii=1,ntask_cont_to
7743         iproc=itask_cont_to(ii)
7744         nn=ncont_sent(ii)
7745 !        write (iout,*) nn," contacts to processor",iproc,
7746 !     &   " of CONT_TO_COMM group"
7747         if (nn.gt.0) then
7748           ireq=ireq+1
7749           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7750             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7751 !          write (iout,*) "ireq,req",ireq,req(ireq)
7752 !          do i=1,nn
7753 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7754 !          enddo
7755         endif
7756       enddo
7757 !      write (iout,*) "number of requests (contacts)",ireq
7758 !      write (iout,*) "req",(req(i),i=1,4)
7759 !      call flush(iout)
7760       if (ireq.gt.0) &
7761        call MPI_Waitall(ireq,req,status_array,ierr)
7762       do iii=1,ntask_cont_from
7763         iproc=itask_cont_from(iii)
7764         nn=ncont_recv(iii)
7765         if (lprn) then
7766         write (iout,*) "Received",nn," contacts from processor",iproc,&
7767          " of CONT_FROM_COMM group"
7768         call flush(iout)
7769         do i=1,nn
7770           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7771         enddo
7772         call flush(iout)
7773         endif
7774         do i=1,nn
7775           ii=zapas_recv(1,i,iii)
7776 ! Flag the received contacts to prevent double-counting
7777           jj=-zapas_recv(2,i,iii)
7778 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7779 !          call flush(iout)
7780           nnn=num_cont_hb(ii)+1
7781           num_cont_hb(ii)=nnn
7782           jcont_hb(nnn,ii)=jj
7783           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7784           ind=3
7785           do kk=1,3
7786             ind=ind+1
7787             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7788           enddo
7789           do kk=1,2
7790             do ll=1,2
7791               ind=ind+1
7792               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7793             enddo
7794           enddo
7795           do jj=1,5
7796             do kk=1,3
7797               do ll=1,2
7798                 do mm=1,2
7799                   ind=ind+1
7800                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7801                 enddo
7802               enddo
7803             enddo
7804           enddo
7805         enddo
7806       enddo
7807       call flush(iout)
7808       if (lprn) then
7809         write (iout,'(a)') 'Contact function values after receive:'
7810         do i=nnt,nct-2
7811           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7812           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7813           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7814         enddo
7815         call flush(iout)
7816       endif
7817    30 continue
7818 #endif
7819       if (lprn) then
7820         write (iout,'(a)') 'Contact function values:'
7821         do i=nnt,nct-2
7822           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7823           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7824           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7825         enddo
7826       endif
7827       ecorr=0.0D0
7828       ecorr5=0.0d0
7829       ecorr6=0.0d0
7830
7831 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7832 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7833 ! Remove the loop below after debugging !!!
7834       do i=nnt,nct
7835         do j=1,3
7836           gradcorr(j,i)=0.0D0
7837           gradxorr(j,i)=0.0D0
7838         enddo
7839       enddo
7840 ! Calculate the dipole-dipole interaction energies
7841       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7842       do i=iatel_s,iatel_e+1
7843         num_conti=num_cont_hb(i)
7844         do jj=1,num_conti
7845           j=jcont_hb(jj,i)
7846 #ifdef MOMENT
7847           call dipole(i,j,jj)
7848 #endif
7849         enddo
7850       enddo
7851       endif
7852 ! Calculate the local-electrostatic correlation terms
7853 !                write (iout,*) "gradcorr5 in eello5 before loop"
7854 !                do iii=1,nres
7855 !                  write (iout,'(i5,3f10.5)')
7856 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7857 !                enddo
7858       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7859 !        write (iout,*) "corr loop i",i
7860         i1=i+1
7861         num_conti=num_cont_hb(i)
7862         num_conti1=num_cont_hb(i+1)
7863         do jj=1,num_conti
7864           j=jcont_hb(jj,i)
7865           jp=iabs(j)
7866           do kk=1,num_conti1
7867             j1=jcont_hb(kk,i1)
7868             jp1=iabs(j1)
7869 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7870 !     &         ' jj=',jj,' kk=',kk
7871 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7872             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7873                 .or. j.lt.0 .and. j1.gt.0) .and. &
7874                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7875 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7876 ! The system gains extra energy.
7877               n_corr=n_corr+1
7878               sqd1=dsqrt(d_cont(jj,i))
7879               sqd2=dsqrt(d_cont(kk,i1))
7880               sred_geom = sqd1*sqd2
7881               IF (sred_geom.lt.cutoff_corr) THEN
7882                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7883                   ekont,fprimcont)
7884 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7885 !d     &         ' jj=',jj,' kk=',kk
7886                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7887                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7888                 do l=1,3
7889                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7890                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7891                 enddo
7892                 n_corr1=n_corr1+1
7893 !d               write (iout,*) 'sred_geom=',sred_geom,
7894 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7895 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7896 !d               write (iout,*) "g_contij",g_contij
7897 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7898 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7899                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7900                 if (wcorr4.gt.0.0d0) &
7901                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7902                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7903                        write (iout,'(a6,4i5,0pf7.3)') &
7904                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7905 !                write (iout,*) "gradcorr5 before eello5"
7906 !                do iii=1,nres
7907 !                  write (iout,'(i5,3f10.5)')
7908 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7909 !                enddo
7910                 if (wcorr5.gt.0.0d0) &
7911                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7912 !                write (iout,*) "gradcorr5 after eello5"
7913 !                do iii=1,nres
7914 !                  write (iout,'(i5,3f10.5)')
7915 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7916 !                enddo
7917                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7918                        write (iout,'(a6,4i5,0pf7.3)') &
7919                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7920 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7921 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7922                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7923                      .or. wturn6.eq.0.0d0))then
7924 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7925                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7926                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7927                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7928 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7929 !d     &            'ecorr6=',ecorr6
7930 !d                write (iout,'(4e15.5)') sred_geom,
7931 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7932 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7933 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7934                 else if (wturn6.gt.0.0d0 &
7935                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7936 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7937                   eturn6=eturn6+eello_turn6(i,jj,kk)
7938                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7939                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7940 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7941                 endif
7942               ENDIF
7943 1111          continue
7944             endif
7945           enddo ! kk
7946         enddo ! jj
7947       enddo ! i
7948       do i=1,nres
7949         num_cont_hb(i)=num_cont_hb_old(i)
7950       enddo
7951 !                write (iout,*) "gradcorr5 in eello5"
7952 !                do iii=1,nres
7953 !                  write (iout,'(i5,3f10.5)')
7954 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7955 !                enddo
7956       return
7957       end subroutine multibody_eello
7958 !-----------------------------------------------------------------------------
7959       subroutine add_hb_contact_eello(ii,jj,itask)
7960 !      implicit real*8 (a-h,o-z)
7961 !      include "DIMENSIONS"
7962 !      include "COMMON.IOUNITS"
7963 !      include "COMMON.CONTACTS"
7964 !      integer,parameter :: maxconts=nres/4
7965       integer,parameter :: max_dim=70
7966       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7967 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7968 !      common /przechowalnia/ zapas
7969
7970       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7971       integer,dimension(4) ::itask
7972 !      write (iout,*) "itask",itask
7973       do i=1,2
7974         iproc=itask(i)
7975         if (iproc.gt.0) then
7976           do j=1,num_cont_hb(ii)
7977             jjc=jcont_hb(j,ii)
7978 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7979             if (jjc.eq.jj) then
7980               ncont_sent(iproc)=ncont_sent(iproc)+1
7981               nn=ncont_sent(iproc)
7982               zapas(1,nn,iproc)=ii
7983               zapas(2,nn,iproc)=jjc
7984               zapas(3,nn,iproc)=d_cont(j,ii)
7985               ind=3
7986               do kk=1,3
7987                 ind=ind+1
7988                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7989               enddo
7990               do kk=1,2
7991                 do ll=1,2
7992                   ind=ind+1
7993                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7994                 enddo
7995               enddo
7996               do jj=1,5
7997                 do kk=1,3
7998                   do ll=1,2
7999                     do mm=1,2
8000                       ind=ind+1
8001                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8002                     enddo
8003                   enddo
8004                 enddo
8005               enddo
8006               exit
8007             endif
8008           enddo
8009         endif
8010       enddo
8011       return
8012       end subroutine add_hb_contact_eello
8013 !-----------------------------------------------------------------------------
8014       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8015 !      implicit real*8 (a-h,o-z)
8016 !      include 'DIMENSIONS'
8017 !      include 'COMMON.IOUNITS'
8018 !      include 'COMMON.DERIV'
8019 !      include 'COMMON.INTERACT'
8020 !      include 'COMMON.CONTACTS'
8021       real(kind=8),dimension(3) :: gx,gx1
8022       logical :: lprn
8023 !el local variables
8024       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8025       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8026                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8027                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8028                    rlocshield
8029
8030       lprn=.false.
8031       eij=facont_hb(jj,i)
8032       ekl=facont_hb(kk,k)
8033       ees0pij=ees0p(jj,i)
8034       ees0pkl=ees0p(kk,k)
8035       ees0mij=ees0m(jj,i)
8036       ees0mkl=ees0m(kk,k)
8037       ekont=eij*ekl
8038       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8039 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8040 ! Following 4 lines for diagnostics.
8041 !d    ees0pkl=0.0D0
8042 !d    ees0pij=1.0D0
8043 !d    ees0mkl=0.0D0
8044 !d    ees0mij=1.0D0
8045 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8046 !     & 'Contacts ',i,j,
8047 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8048 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8049 !     & 'gradcorr_long'
8050 ! Calculate the multi-body contribution to energy.
8051 !      ecorr=ecorr+ekont*ees
8052 ! Calculate multi-body contributions to the gradient.
8053       coeffpees0pij=coeffp*ees0pij
8054       coeffmees0mij=coeffm*ees0mij
8055       coeffpees0pkl=coeffp*ees0pkl
8056       coeffmees0mkl=coeffm*ees0mkl
8057       do ll=1,3
8058 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8059         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8060         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8061         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8062         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8063         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8064         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8065 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8066         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8067         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8068         coeffmees0mij*gacontm_hb1(ll,kk,k))
8069         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8070         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8071         coeffmees0mij*gacontm_hb2(ll,kk,k))
8072         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8073            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8074            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8075         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8076         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8077         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8078            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8079            coeffmees0mij*gacontm_hb3(ll,kk,k))
8080         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8081         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8082 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8083       enddo
8084 !      write (iout,*)
8085 !grad      do m=i+1,j-1
8086 !grad        do ll=1,3
8087 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8088 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8089 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8090 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8091 !grad        enddo
8092 !grad      enddo
8093 !grad      do m=k+1,l-1
8094 !grad        do ll=1,3
8095 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8096 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8097 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8098 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8099 !grad        enddo
8100 !grad      enddo
8101 !      write (iout,*) "ehbcorr",ekont*ees
8102       ehbcorr=ekont*ees
8103       if (shield_mode.gt.0) then
8104        j=ees0plist(jj,i)
8105        l=ees0plist(kk,k)
8106 !C        print *,i,j,fac_shield(i),fac_shield(j),
8107 !C     &fac_shield(k),fac_shield(l)
8108         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8109            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8110           do ilist=1,ishield_list(i)
8111            iresshield=shield_list(ilist,i)
8112            do m=1,3
8113            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8114            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8115                    rlocshield  &
8116             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8117             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8118             +rlocshield
8119            enddo
8120           enddo
8121           do ilist=1,ishield_list(j)
8122            iresshield=shield_list(ilist,j)
8123            do m=1,3
8124            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8125            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8126                    rlocshield &
8127             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8128            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8129             +rlocshield
8130            enddo
8131           enddo
8132
8133           do ilist=1,ishield_list(k)
8134            iresshield=shield_list(ilist,k)
8135            do m=1,3
8136            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8137            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8138                    rlocshield &
8139             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8140            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8141             +rlocshield
8142            enddo
8143           enddo
8144           do ilist=1,ishield_list(l)
8145            iresshield=shield_list(ilist,l)
8146            do m=1,3
8147            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8148            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8149                    rlocshield &
8150             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8151            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8152             +rlocshield
8153            enddo
8154           enddo
8155           do m=1,3
8156             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8157                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8158             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8159                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8160             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8161                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8162             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8163                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8164
8165             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8166                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8167             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8168                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8169             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8170                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8171             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8172                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8173
8174            enddo
8175       endif
8176       endif
8177       return
8178       end function ehbcorr
8179 #ifdef MOMENT
8180 !-----------------------------------------------------------------------------
8181       subroutine dipole(i,j,jj)
8182 !      implicit real*8 (a-h,o-z)
8183 !      include 'DIMENSIONS'
8184 !      include 'COMMON.IOUNITS'
8185 !      include 'COMMON.CHAIN'
8186 !      include 'COMMON.FFIELD'
8187 !      include 'COMMON.DERIV'
8188 !      include 'COMMON.INTERACT'
8189 !      include 'COMMON.CONTACTS'
8190 !      include 'COMMON.TORSION'
8191 !      include 'COMMON.VAR'
8192 !      include 'COMMON.GEO'
8193       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8194       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8195       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8196
8197       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8198       allocate(dipderx(3,5,4,maxconts,nres))
8199 !
8200
8201       iti1 = itortyp(itype(i+1,1))
8202       if (j.lt.nres-1) then
8203         itj1 = itortyp(itype(j+1,1))
8204       else
8205         itj1=ntortyp+1
8206       endif
8207       do iii=1,2
8208         dipi(iii,1)=Ub2(iii,i)
8209         dipderi(iii)=Ub2der(iii,i)
8210         dipi(iii,2)=b1(iii,iti1)
8211         dipj(iii,1)=Ub2(iii,j)
8212         dipderj(iii)=Ub2der(iii,j)
8213         dipj(iii,2)=b1(iii,itj1)
8214       enddo
8215       kkk=0
8216       do iii=1,2
8217         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8218         do jjj=1,2
8219           kkk=kkk+1
8220           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8221         enddo
8222       enddo
8223       do kkk=1,5
8224         do lll=1,3
8225           mmm=0
8226           do iii=1,2
8227             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8228               auxvec(1))
8229             do jjj=1,2
8230               mmm=mmm+1
8231               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8232             enddo
8233           enddo
8234         enddo
8235       enddo
8236       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8237       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8238       do iii=1,2
8239         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8240       enddo
8241       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8242       do iii=1,2
8243         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8244       enddo
8245       return
8246       end subroutine dipole
8247 #endif
8248 !-----------------------------------------------------------------------------
8249       subroutine calc_eello(i,j,k,l,jj,kk)
8250 !
8251 ! This subroutine computes matrices and vectors needed to calculate
8252 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8253 !
8254       use comm_kut
8255 !      implicit real*8 (a-h,o-z)
8256 !      include 'DIMENSIONS'
8257 !      include 'COMMON.IOUNITS'
8258 !      include 'COMMON.CHAIN'
8259 !      include 'COMMON.DERIV'
8260 !      include 'COMMON.INTERACT'
8261 !      include 'COMMON.CONTACTS'
8262 !      include 'COMMON.TORSION'
8263 !      include 'COMMON.VAR'
8264 !      include 'COMMON.GEO'
8265 !      include 'COMMON.FFIELD'
8266       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8267       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8268       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8269               itj1
8270 !el      logical :: lprn
8271 !el      common /kutas/ lprn
8272 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8273 !d     & ' jj=',jj,' kk=',kk
8274 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8275 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8276 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8277       do iii=1,2
8278         do jjj=1,2
8279           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8280           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8281         enddo
8282       enddo
8283       call transpose2(aa1(1,1),aa1t(1,1))
8284       call transpose2(aa2(1,1),aa2t(1,1))
8285       do kkk=1,5
8286         do lll=1,3
8287           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8288             aa1tder(1,1,lll,kkk))
8289           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8290             aa2tder(1,1,lll,kkk))
8291         enddo
8292       enddo
8293       if (l.eq.j+1) then
8294 ! parallel orientation of the two CA-CA-CA frames.
8295         if (i.gt.1) then
8296           iti=itortyp(itype(i,1))
8297         else
8298           iti=ntortyp+1
8299         endif
8300         itk1=itortyp(itype(k+1,1))
8301         itj=itortyp(itype(j,1))
8302         if (l.lt.nres-1) then
8303           itl1=itortyp(itype(l+1,1))
8304         else
8305           itl1=ntortyp+1
8306         endif
8307 ! A1 kernel(j+1) A2T
8308 !d        do iii=1,2
8309 !d          write (iout,'(3f10.5,5x,3f10.5)')
8310 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8311 !d        enddo
8312         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8313          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8314          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8315 ! Following matrices are needed only for 6-th order cumulants
8316         IF (wcorr6.gt.0.0d0) THEN
8317         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8318          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8319          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8320         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8321          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8322          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8323          ADtEAderx(1,1,1,1,1,1))
8324         lprn=.false.
8325         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8326          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8327          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8328          ADtEA1derx(1,1,1,1,1,1))
8329         ENDIF
8330 ! End 6-th order cumulants
8331 !d        lprn=.false.
8332 !d        if (lprn) then
8333 !d        write (2,*) 'In calc_eello6'
8334 !d        do iii=1,2
8335 !d          write (2,*) 'iii=',iii
8336 !d          do kkk=1,5
8337 !d            write (2,*) 'kkk=',kkk
8338 !d            do jjj=1,2
8339 !d              write (2,'(3(2f10.5),5x)')
8340 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8341 !d            enddo
8342 !d          enddo
8343 !d        enddo
8344 !d        endif
8345         call transpose2(EUgder(1,1,k),auxmat(1,1))
8346         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8347         call transpose2(EUg(1,1,k),auxmat(1,1))
8348         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8349         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8350         do iii=1,2
8351           do kkk=1,5
8352             do lll=1,3
8353               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8354                 EAEAderx(1,1,lll,kkk,iii,1))
8355             enddo
8356           enddo
8357         enddo
8358 ! A1T kernel(i+1) A2
8359         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8360          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8361          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8362 ! Following matrices are needed only for 6-th order cumulants
8363         IF (wcorr6.gt.0.0d0) THEN
8364         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8365          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8366          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8367         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8368          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8369          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8370          ADtEAderx(1,1,1,1,1,2))
8371         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8372          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8373          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8374          ADtEA1derx(1,1,1,1,1,2))
8375         ENDIF
8376 ! End 6-th order cumulants
8377         call transpose2(EUgder(1,1,l),auxmat(1,1))
8378         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8379         call transpose2(EUg(1,1,l),auxmat(1,1))
8380         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8381         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8382         do iii=1,2
8383           do kkk=1,5
8384             do lll=1,3
8385               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8386                 EAEAderx(1,1,lll,kkk,iii,2))
8387             enddo
8388           enddo
8389         enddo
8390 ! AEAb1 and AEAb2
8391 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8392 ! They are needed only when the fifth- or the sixth-order cumulants are
8393 ! indluded.
8394         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8395         call transpose2(AEA(1,1,1),auxmat(1,1))
8396         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8397         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8398         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8399         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8400         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8401         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8402         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8403         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8404         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8405         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8406         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8407         call transpose2(AEA(1,1,2),auxmat(1,1))
8408         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8409         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8410         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8411         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8412         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8413         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8414         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8415         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8416         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8417         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8418         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8419 ! Calculate the Cartesian derivatives of the vectors.
8420         do iii=1,2
8421           do kkk=1,5
8422             do lll=1,3
8423               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8424               call matvec2(auxmat(1,1),b1(1,iti),&
8425                 AEAb1derx(1,lll,kkk,iii,1,1))
8426               call matvec2(auxmat(1,1),Ub2(1,i),&
8427                 AEAb2derx(1,lll,kkk,iii,1,1))
8428               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8429                 AEAb1derx(1,lll,kkk,iii,2,1))
8430               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8431                 AEAb2derx(1,lll,kkk,iii,2,1))
8432               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8433               call matvec2(auxmat(1,1),b1(1,itj),&
8434                 AEAb1derx(1,lll,kkk,iii,1,2))
8435               call matvec2(auxmat(1,1),Ub2(1,j),&
8436                 AEAb2derx(1,lll,kkk,iii,1,2))
8437               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8438                 AEAb1derx(1,lll,kkk,iii,2,2))
8439               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8440                 AEAb2derx(1,lll,kkk,iii,2,2))
8441             enddo
8442           enddo
8443         enddo
8444         ENDIF
8445 ! End vectors
8446       else
8447 ! Antiparallel orientation of the two CA-CA-CA frames.
8448         if (i.gt.1) then
8449           iti=itortyp(itype(i,1))
8450         else
8451           iti=ntortyp+1
8452         endif
8453         itk1=itortyp(itype(k+1,1))
8454         itl=itortyp(itype(l,1))
8455         itj=itortyp(itype(j,1))
8456         if (j.lt.nres-1) then
8457           itj1=itortyp(itype(j+1,1))
8458         else
8459           itj1=ntortyp+1
8460         endif
8461 ! A2 kernel(j-1)T A1T
8462         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8463          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8464          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8465 ! Following matrices are needed only for 6-th order cumulants
8466         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8467            j.eq.i+4 .and. l.eq.i+3)) THEN
8468         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8469          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8470          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8471         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8472          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8473          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8474          ADtEAderx(1,1,1,1,1,1))
8475         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8476          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8477          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8478          ADtEA1derx(1,1,1,1,1,1))
8479         ENDIF
8480 ! End 6-th order cumulants
8481         call transpose2(EUgder(1,1,k),auxmat(1,1))
8482         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8483         call transpose2(EUg(1,1,k),auxmat(1,1))
8484         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8485         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8486         do iii=1,2
8487           do kkk=1,5
8488             do lll=1,3
8489               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8490                 EAEAderx(1,1,lll,kkk,iii,1))
8491             enddo
8492           enddo
8493         enddo
8494 ! A2T kernel(i+1)T A1
8495         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8496          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8497          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8498 ! Following matrices are needed only for 6-th order cumulants
8499         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8500            j.eq.i+4 .and. l.eq.i+3)) THEN
8501         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8502          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8503          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8504         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8505          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8506          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8507          ADtEAderx(1,1,1,1,1,2))
8508         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8509          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8510          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8511          ADtEA1derx(1,1,1,1,1,2))
8512         ENDIF
8513 ! End 6-th order cumulants
8514         call transpose2(EUgder(1,1,j),auxmat(1,1))
8515         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8516         call transpose2(EUg(1,1,j),auxmat(1,1))
8517         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8518         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8519         do iii=1,2
8520           do kkk=1,5
8521             do lll=1,3
8522               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8523                 EAEAderx(1,1,lll,kkk,iii,2))
8524             enddo
8525           enddo
8526         enddo
8527 ! AEAb1 and AEAb2
8528 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8529 ! They are needed only when the fifth- or the sixth-order cumulants are
8530 ! indluded.
8531         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8532           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8533         call transpose2(AEA(1,1,1),auxmat(1,1))
8534         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8535         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8536         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8537         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8538         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8539         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8540         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8541         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8542         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8543         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8544         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8545         call transpose2(AEA(1,1,2),auxmat(1,1))
8546         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8547         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8548         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8549         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8550         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8551         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8552         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8553         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8554         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8555         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8556         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8557 ! Calculate the Cartesian derivatives of the vectors.
8558         do iii=1,2
8559           do kkk=1,5
8560             do lll=1,3
8561               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8562               call matvec2(auxmat(1,1),b1(1,iti),&
8563                 AEAb1derx(1,lll,kkk,iii,1,1))
8564               call matvec2(auxmat(1,1),Ub2(1,i),&
8565                 AEAb2derx(1,lll,kkk,iii,1,1))
8566               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8567                 AEAb1derx(1,lll,kkk,iii,2,1))
8568               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8569                 AEAb2derx(1,lll,kkk,iii,2,1))
8570               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8571               call matvec2(auxmat(1,1),b1(1,itl),&
8572                 AEAb1derx(1,lll,kkk,iii,1,2))
8573               call matvec2(auxmat(1,1),Ub2(1,l),&
8574                 AEAb2derx(1,lll,kkk,iii,1,2))
8575               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8576                 AEAb1derx(1,lll,kkk,iii,2,2))
8577               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8578                 AEAb2derx(1,lll,kkk,iii,2,2))
8579             enddo
8580           enddo
8581         enddo
8582         ENDIF
8583 ! End vectors
8584       endif
8585       return
8586       end subroutine calc_eello
8587 !-----------------------------------------------------------------------------
8588       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8589       use comm_kut
8590       implicit none
8591       integer :: nderg
8592       logical :: transp
8593       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8594       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8595       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8596       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8597       integer :: iii,kkk,lll
8598       integer :: jjj,mmm
8599 !el      logical :: lprn
8600 !el      common /kutas/ lprn
8601       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8602       do iii=1,nderg
8603         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8604           AKAderg(1,1,iii))
8605       enddo
8606 !d      if (lprn) write (2,*) 'In kernel'
8607       do kkk=1,5
8608 !d        if (lprn) write (2,*) 'kkk=',kkk
8609         do lll=1,3
8610           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8611             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8612 !d          if (lprn) then
8613 !d            write (2,*) 'lll=',lll
8614 !d            write (2,*) 'iii=1'
8615 !d            do jjj=1,2
8616 !d              write (2,'(3(2f10.5),5x)')
8617 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8618 !d            enddo
8619 !d          endif
8620           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8621             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8622 !d          if (lprn) then
8623 !d            write (2,*) 'lll=',lll
8624 !d            write (2,*) 'iii=2'
8625 !d            do jjj=1,2
8626 !d              write (2,'(3(2f10.5),5x)')
8627 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8628 !d            enddo
8629 !d          endif
8630         enddo
8631       enddo
8632       return
8633       end subroutine kernel
8634 !-----------------------------------------------------------------------------
8635       real(kind=8) function eello4(i,j,k,l,jj,kk)
8636 !      implicit real*8 (a-h,o-z)
8637 !      include 'DIMENSIONS'
8638 !      include 'COMMON.IOUNITS'
8639 !      include 'COMMON.CHAIN'
8640 !      include 'COMMON.DERIV'
8641 !      include 'COMMON.INTERACT'
8642 !      include 'COMMON.CONTACTS'
8643 !      include 'COMMON.TORSION'
8644 !      include 'COMMON.VAR'
8645 !      include 'COMMON.GEO'
8646       real(kind=8),dimension(2,2) :: pizda
8647       real(kind=8),dimension(3) :: ggg1,ggg2
8648       real(kind=8) ::  eel4,glongij,glongkl
8649       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8650 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8651 !d        eello4=0.0d0
8652 !d        return
8653 !d      endif
8654 !d      print *,'eello4:',i,j,k,l,jj,kk
8655 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8656 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8657 !old      eij=facont_hb(jj,i)
8658 !old      ekl=facont_hb(kk,k)
8659 !old      ekont=eij*ekl
8660       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8661 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8662       gcorr_loc(k-1)=gcorr_loc(k-1) &
8663          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8664       if (l.eq.j+1) then
8665         gcorr_loc(l-1)=gcorr_loc(l-1) &
8666            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8667       else
8668         gcorr_loc(j-1)=gcorr_loc(j-1) &
8669            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8670       endif
8671       do iii=1,2
8672         do kkk=1,5
8673           do lll=1,3
8674             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8675                               -EAEAderx(2,2,lll,kkk,iii,1)
8676 !d            derx(lll,kkk,iii)=0.0d0
8677           enddo
8678         enddo
8679       enddo
8680 !d      gcorr_loc(l-1)=0.0d0
8681 !d      gcorr_loc(j-1)=0.0d0
8682 !d      gcorr_loc(k-1)=0.0d0
8683 !d      eel4=1.0d0
8684 !d      write (iout,*)'Contacts have occurred for peptide groups',
8685 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8686 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8687       if (j.lt.nres-1) then
8688         j1=j+1
8689         j2=j-1
8690       else
8691         j1=j-1
8692         j2=j-2
8693       endif
8694       if (l.lt.nres-1) then
8695         l1=l+1
8696         l2=l-1
8697       else
8698         l1=l-1
8699         l2=l-2
8700       endif
8701       do ll=1,3
8702 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8703 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8704         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8705         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8706 !grad        ghalf=0.5d0*ggg1(ll)
8707         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8708         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8709         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8710         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8711         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8712         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8713 !grad        ghalf=0.5d0*ggg2(ll)
8714         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8715         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8716         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8717         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8718         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8719         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8720       enddo
8721 !grad      do m=i+1,j-1
8722 !grad        do ll=1,3
8723 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8724 !grad        enddo
8725 !grad      enddo
8726 !grad      do m=k+1,l-1
8727 !grad        do ll=1,3
8728 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8729 !grad        enddo
8730 !grad      enddo
8731 !grad      do m=i+2,j2
8732 !grad        do ll=1,3
8733 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8734 !grad        enddo
8735 !grad      enddo
8736 !grad      do m=k+2,l2
8737 !grad        do ll=1,3
8738 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8739 !grad        enddo
8740 !grad      enddo
8741 !d      do iii=1,nres-3
8742 !d        write (2,*) iii,gcorr_loc(iii)
8743 !d      enddo
8744       eello4=ekont*eel4
8745 !d      write (2,*) 'ekont',ekont
8746 !d      write (iout,*) 'eello4',ekont*eel4
8747       return
8748       end function eello4
8749 !-----------------------------------------------------------------------------
8750       real(kind=8) function eello5(i,j,k,l,jj,kk)
8751 !      implicit real*8 (a-h,o-z)
8752 !      include 'DIMENSIONS'
8753 !      include 'COMMON.IOUNITS'
8754 !      include 'COMMON.CHAIN'
8755 !      include 'COMMON.DERIV'
8756 !      include 'COMMON.INTERACT'
8757 !      include 'COMMON.CONTACTS'
8758 !      include 'COMMON.TORSION'
8759 !      include 'COMMON.VAR'
8760 !      include 'COMMON.GEO'
8761       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8762       real(kind=8),dimension(2) :: vv
8763       real(kind=8),dimension(3) :: ggg1,ggg2
8764       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8765       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8766       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8767 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8768 !                                                                              C
8769 !                            Parallel chains                                   C
8770 !                                                                              C
8771 !          o             o                   o             o                   C
8772 !         /l\           / \             \   / \           / \   /              C
8773 !        /   \         /   \             \ /   \         /   \ /               C
8774 !       j| o |l1       | o |                o| o |         | o |o                C
8775 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8776 !      \i/   \         /   \ /             /   \         /   \                 C
8777 !       o    k1             o                                                  C
8778 !         (I)          (II)                (III)          (IV)                 C
8779 !                                                                              C
8780 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8781 !                                                                              C
8782 !                            Antiparallel chains                               C
8783 !                                                                              C
8784 !          o             o                   o             o                   C
8785 !         /j\           / \             \   / \           / \   /              C
8786 !        /   \         /   \             \ /   \         /   \ /               C
8787 !      j1| o |l        | o |                o| o |         | o |o                C
8788 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8789 !      \i/   \         /   \ /             /   \         /   \                 C
8790 !       o     k1            o                                                  C
8791 !         (I)          (II)                (III)          (IV)                 C
8792 !                                                                              C
8793 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8794 !                                                                              C
8795 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8796 !                                                                              C
8797 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8798 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8799 !d        eello5=0.0d0
8800 !d        return
8801 !d      endif
8802 !d      write (iout,*)
8803 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8804 !d     &   ' and',k,l
8805       itk=itortyp(itype(k,1))
8806       itl=itortyp(itype(l,1))
8807       itj=itortyp(itype(j,1))
8808       eello5_1=0.0d0
8809       eello5_2=0.0d0
8810       eello5_3=0.0d0
8811       eello5_4=0.0d0
8812 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8813 !d     &   eel5_3_num,eel5_4_num)
8814       do iii=1,2
8815         do kkk=1,5
8816           do lll=1,3
8817             derx(lll,kkk,iii)=0.0d0
8818           enddo
8819         enddo
8820       enddo
8821 !d      eij=facont_hb(jj,i)
8822 !d      ekl=facont_hb(kk,k)
8823 !d      ekont=eij*ekl
8824 !d      write (iout,*)'Contacts have occurred for peptide groups',
8825 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8826 !d      goto 1111
8827 ! Contribution from the graph I.
8828 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8829 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8830       call transpose2(EUg(1,1,k),auxmat(1,1))
8831       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8832       vv(1)=pizda(1,1)-pizda(2,2)
8833       vv(2)=pizda(1,2)+pizda(2,1)
8834       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8835        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8836 ! Explicit gradient in virtual-dihedral angles.
8837       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8838        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8839        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8840       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8841       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8842       vv(1)=pizda(1,1)-pizda(2,2)
8843       vv(2)=pizda(1,2)+pizda(2,1)
8844       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8845        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8846        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8847       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8848       vv(1)=pizda(1,1)-pizda(2,2)
8849       vv(2)=pizda(1,2)+pizda(2,1)
8850       if (l.eq.j+1) then
8851         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8852          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8853          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8854       else
8855         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8856          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8857          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8858       endif
8859 ! Cartesian gradient
8860       do iii=1,2
8861         do kkk=1,5
8862           do lll=1,3
8863             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8864               pizda(1,1))
8865             vv(1)=pizda(1,1)-pizda(2,2)
8866             vv(2)=pizda(1,2)+pizda(2,1)
8867             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8868              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8869              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8870           enddo
8871         enddo
8872       enddo
8873 !      goto 1112
8874 !1111  continue
8875 ! Contribution from graph II
8876       call transpose2(EE(1,1,itk),auxmat(1,1))
8877       call matmat2(auxmat(1,1),AEA(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       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8881        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8882 ! Explicit gradient in virtual-dihedral angles.
8883       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8884        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8885       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8886       vv(1)=pizda(1,1)+pizda(2,2)
8887       vv(2)=pizda(2,1)-pizda(1,2)
8888       if (l.eq.j+1) then
8889         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8890          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8891          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8892       else
8893         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8894          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8895          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8896       endif
8897 ! Cartesian gradient
8898       do iii=1,2
8899         do kkk=1,5
8900           do lll=1,3
8901             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8902               pizda(1,1))
8903             vv(1)=pizda(1,1)+pizda(2,2)
8904             vv(2)=pizda(2,1)-pizda(1,2)
8905             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8906              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8907              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8908           enddo
8909         enddo
8910       enddo
8911 !d      goto 1112
8912 !d1111  continue
8913       if (l.eq.j+1) then
8914 !d        goto 1110
8915 ! Parallel orientation
8916 ! Contribution from graph III
8917         call transpose2(EUg(1,1,l),auxmat(1,1))
8918         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8919         vv(1)=pizda(1,1)-pizda(2,2)
8920         vv(2)=pizda(1,2)+pizda(2,1)
8921         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8922          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8923 ! Explicit gradient in virtual-dihedral angles.
8924         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8925          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8926          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8927         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8928         vv(1)=pizda(1,1)-pizda(2,2)
8929         vv(2)=pizda(1,2)+pizda(2,1)
8930         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8931          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8932          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8933         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8934         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8935         vv(1)=pizda(1,1)-pizda(2,2)
8936         vv(2)=pizda(1,2)+pizda(2,1)
8937         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8938          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8939          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8940 ! Cartesian gradient
8941         do iii=1,2
8942           do kkk=1,5
8943             do lll=1,3
8944               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8945                 pizda(1,1))
8946               vv(1)=pizda(1,1)-pizda(2,2)
8947               vv(2)=pizda(1,2)+pizda(2,1)
8948               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8949                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8950                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8951             enddo
8952           enddo
8953         enddo
8954 !d        goto 1112
8955 ! Contribution from graph IV
8956 !d1110    continue
8957         call transpose2(EE(1,1,itl),auxmat(1,1))
8958         call matmat2(auxmat(1,1),AEA(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         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8962          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8963 ! Explicit gradient in virtual-dihedral angles.
8964         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8965          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8966         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8967         vv(1)=pizda(1,1)+pizda(2,2)
8968         vv(2)=pizda(2,1)-pizda(1,2)
8969         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8970          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8971          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8972 ! Cartesian gradient
8973         do iii=1,2
8974           do kkk=1,5
8975             do lll=1,3
8976               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8977                 pizda(1,1))
8978               vv(1)=pizda(1,1)+pizda(2,2)
8979               vv(2)=pizda(2,1)-pizda(1,2)
8980               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8981                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8982                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8983             enddo
8984           enddo
8985         enddo
8986       else
8987 ! Antiparallel orientation
8988 ! Contribution from graph III
8989 !        goto 1110
8990         call transpose2(EUg(1,1,j),auxmat(1,1))
8991         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8992         vv(1)=pizda(1,1)-pizda(2,2)
8993         vv(2)=pizda(1,2)+pizda(2,1)
8994         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8995          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8996 ! Explicit gradient in virtual-dihedral angles.
8997         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8998          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8999          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9000         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9001         vv(1)=pizda(1,1)-pizda(2,2)
9002         vv(2)=pizda(1,2)+pizda(2,1)
9003         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9004          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9005          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9006         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9007         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9008         vv(1)=pizda(1,1)-pizda(2,2)
9009         vv(2)=pizda(1,2)+pizda(2,1)
9010         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9011          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9012          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9013 ! Cartesian gradient
9014         do iii=1,2
9015           do kkk=1,5
9016             do lll=1,3
9017               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9018                 pizda(1,1))
9019               vv(1)=pizda(1,1)-pizda(2,2)
9020               vv(2)=pizda(1,2)+pizda(2,1)
9021               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9022                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9023                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9024             enddo
9025           enddo
9026         enddo
9027 !d        goto 1112
9028 ! Contribution from graph IV
9029 1110    continue
9030         call transpose2(EE(1,1,itj),auxmat(1,1))
9031         call matmat2(auxmat(1,1),AEA(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         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9035          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9036 ! Explicit gradient in virtual-dihedral angles.
9037         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9038          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9039         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9040         vv(1)=pizda(1,1)+pizda(2,2)
9041         vv(2)=pizda(2,1)-pizda(1,2)
9042         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9043          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9044          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9045 ! Cartesian gradient
9046         do iii=1,2
9047           do kkk=1,5
9048             do lll=1,3
9049               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9050                 pizda(1,1))
9051               vv(1)=pizda(1,1)+pizda(2,2)
9052               vv(2)=pizda(2,1)-pizda(1,2)
9053               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9054                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9055                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9056             enddo
9057           enddo
9058         enddo
9059       endif
9060 1112  continue
9061       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9062 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9063 !d        write (2,*) 'ijkl',i,j,k,l
9064 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9065 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9066 !d      endif
9067 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9068 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9069 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9070 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9071       if (j.lt.nres-1) then
9072         j1=j+1
9073         j2=j-1
9074       else
9075         j1=j-1
9076         j2=j-2
9077       endif
9078       if (l.lt.nres-1) then
9079         l1=l+1
9080         l2=l-1
9081       else
9082         l1=l-1
9083         l2=l-2
9084       endif
9085 !d      eij=1.0d0
9086 !d      ekl=1.0d0
9087 !d      ekont=1.0d0
9088 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9089 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9090 !        summed up outside the subrouine as for the other subroutines
9091 !        handling long-range interactions. The old code is commented out
9092 !        with "cgrad" to keep track of changes.
9093       do ll=1,3
9094 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9095 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9096         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9097         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9098 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9099 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9100 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9101 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9102 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9103 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9104 !     &   gradcorr5ij,
9105 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9106 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9107 !grad        ghalf=0.5d0*ggg1(ll)
9108 !d        ghalf=0.0d0
9109         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9110         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9111         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9112         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9113         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9114         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9115 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9116 !grad        ghalf=0.5d0*ggg2(ll)
9117         ghalf=0.0d0
9118         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9119         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9120         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9121         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9122         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9123         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9124       enddo
9125 !d      goto 1112
9126 !grad      do m=i+1,j-1
9127 !grad        do ll=1,3
9128 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9129 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9130 !grad        enddo
9131 !grad      enddo
9132 !grad      do m=k+1,l-1
9133 !grad        do ll=1,3
9134 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9135 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9136 !grad        enddo
9137 !grad      enddo
9138 !1112  continue
9139 !grad      do m=i+2,j2
9140 !grad        do ll=1,3
9141 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9142 !grad        enddo
9143 !grad      enddo
9144 !grad      do m=k+2,l2
9145 !grad        do ll=1,3
9146 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9147 !grad        enddo
9148 !grad      enddo
9149 !d      do iii=1,nres-3
9150 !d        write (2,*) iii,g_corr5_loc(iii)
9151 !d      enddo
9152       eello5=ekont*eel5
9153 !d      write (2,*) 'ekont',ekont
9154 !d      write (iout,*) 'eello5',ekont*eel5
9155       return
9156       end function eello5
9157 !-----------------------------------------------------------------------------
9158       real(kind=8) function eello6(i,j,k,l,jj,kk)
9159 !      implicit real*8 (a-h,o-z)
9160 !      include 'DIMENSIONS'
9161 !      include 'COMMON.IOUNITS'
9162 !      include 'COMMON.CHAIN'
9163 !      include 'COMMON.DERIV'
9164 !      include 'COMMON.INTERACT'
9165 !      include 'COMMON.CONTACTS'
9166 !      include 'COMMON.TORSION'
9167 !      include 'COMMON.VAR'
9168 !      include 'COMMON.GEO'
9169 !      include 'COMMON.FFIELD'
9170       real(kind=8),dimension(3) :: ggg1,ggg2
9171       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9172                    eello6_6,eel6
9173       real(kind=8) :: gradcorr6ij,gradcorr6kl
9174       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9175 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9176 !d        eello6=0.0d0
9177 !d        return
9178 !d      endif
9179 !d      write (iout,*)
9180 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9181 !d     &   ' and',k,l
9182       eello6_1=0.0d0
9183       eello6_2=0.0d0
9184       eello6_3=0.0d0
9185       eello6_4=0.0d0
9186       eello6_5=0.0d0
9187       eello6_6=0.0d0
9188 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9189 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9190       do iii=1,2
9191         do kkk=1,5
9192           do lll=1,3
9193             derx(lll,kkk,iii)=0.0d0
9194           enddo
9195         enddo
9196       enddo
9197 !d      eij=facont_hb(jj,i)
9198 !d      ekl=facont_hb(kk,k)
9199 !d      ekont=eij*ekl
9200 !d      eij=1.0d0
9201 !d      ekl=1.0d0
9202 !d      ekont=1.0d0
9203       if (l.eq.j+1) then
9204         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9205         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9206         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9207         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9208         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9209         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9210       else
9211         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9212         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9213         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9214         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9215         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9216           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9217         else
9218           eello6_5=0.0d0
9219         endif
9220         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9221       endif
9222 ! If turn contributions are considered, they will be handled separately.
9223       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9224 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9225 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9226 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9227 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9228 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9229 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9230 !d      goto 1112
9231       if (j.lt.nres-1) then
9232         j1=j+1
9233         j2=j-1
9234       else
9235         j1=j-1
9236         j2=j-2
9237       endif
9238       if (l.lt.nres-1) then
9239         l1=l+1
9240         l2=l-1
9241       else
9242         l1=l-1
9243         l2=l-2
9244       endif
9245       do ll=1,3
9246 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9247 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9248 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9249 !grad        ghalf=0.5d0*ggg1(ll)
9250 !d        ghalf=0.0d0
9251         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9252         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9253         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9254         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9255         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9256         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9257         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9258         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9259 !grad        ghalf=0.5d0*ggg2(ll)
9260 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9261 !d        ghalf=0.0d0
9262         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9263         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9264         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9265         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9266         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9267         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9268       enddo
9269 !d      goto 1112
9270 !grad      do m=i+1,j-1
9271 !grad        do ll=1,3
9272 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9273 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9274 !grad        enddo
9275 !grad      enddo
9276 !grad      do m=k+1,l-1
9277 !grad        do ll=1,3
9278 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9279 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9280 !grad        enddo
9281 !grad      enddo
9282 !grad1112  continue
9283 !grad      do m=i+2,j2
9284 !grad        do ll=1,3
9285 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9286 !grad        enddo
9287 !grad      enddo
9288 !grad      do m=k+2,l2
9289 !grad        do ll=1,3
9290 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9291 !grad        enddo
9292 !grad      enddo
9293 !d      do iii=1,nres-3
9294 !d        write (2,*) iii,g_corr6_loc(iii)
9295 !d      enddo
9296       eello6=ekont*eel6
9297 !d      write (2,*) 'ekont',ekont
9298 !d      write (iout,*) 'eello6',ekont*eel6
9299       return
9300       end function eello6
9301 !-----------------------------------------------------------------------------
9302       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9303       use comm_kut
9304 !      implicit real*8 (a-h,o-z)
9305 !      include 'DIMENSIONS'
9306 !      include 'COMMON.IOUNITS'
9307 !      include 'COMMON.CHAIN'
9308 !      include 'COMMON.DERIV'
9309 !      include 'COMMON.INTERACT'
9310 !      include 'COMMON.CONTACTS'
9311 !      include 'COMMON.TORSION'
9312 !      include 'COMMON.VAR'
9313 !      include 'COMMON.GEO'
9314       real(kind=8),dimension(2) :: vv,vv1
9315       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9316       logical :: swap
9317 !el      logical :: lprn
9318 !el      common /kutas/ lprn
9319       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9320       real(kind=8) :: s1,s2,s3,s4,s5
9321 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9322 !                                                                              C
9323 !      Parallel       Antiparallel                                             C
9324 !                                                                              C
9325 !          o             o                                                     C
9326 !         /l\           /j\                                                    C
9327 !        /   \         /   \                                                   C
9328 !       /| o |         | o |\                                                  C
9329 !     \ j|/k\|  /   \  |/k\|l /                                                C
9330 !      \ /   \ /     \ /   \ /                                                 C
9331 !       o     o       o     o                                                  C
9332 !       i             i                                                        C
9333 !                                                                              C
9334 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9335       itk=itortyp(itype(k,1))
9336       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9337       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9338       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9339       call transpose2(EUgC(1,1,k),auxmat(1,1))
9340       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9341       vv1(1)=pizda1(1,1)-pizda1(2,2)
9342       vv1(2)=pizda1(1,2)+pizda1(2,1)
9343       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9344       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9345       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9346       s5=scalar2(vv(1),Dtobr2(1,i))
9347 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9348       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9349       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9350        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9351        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9352        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9353        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9354        +scalar2(vv(1),Dtobr2der(1,i)))
9355       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9356       vv1(1)=pizda1(1,1)-pizda1(2,2)
9357       vv1(2)=pizda1(1,2)+pizda1(2,1)
9358       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9359       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9360       if (l.eq.j+1) then
9361         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9362        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9363        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9364        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9365        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9366       else
9367         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9368        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9369        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9370        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9371        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9372       endif
9373       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9374       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9375       vv1(1)=pizda1(1,1)-pizda1(2,2)
9376       vv1(2)=pizda1(1,2)+pizda1(2,1)
9377       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9378        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9379        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9380        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9381       do iii=1,2
9382         if (swap) then
9383           ind=3-iii
9384         else
9385           ind=iii
9386         endif
9387         do kkk=1,5
9388           do lll=1,3
9389             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9390             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9391             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9392             call transpose2(EUgC(1,1,k),auxmat(1,1))
9393             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9394               pizda1(1,1))
9395             vv1(1)=pizda1(1,1)-pizda1(2,2)
9396             vv1(2)=pizda1(1,2)+pizda1(2,1)
9397             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9398             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9399              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9400             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9401              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9402             s5=scalar2(vv(1),Dtobr2(1,i))
9403             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9404           enddo
9405         enddo
9406       enddo
9407       return
9408       end function eello6_graph1
9409 !-----------------------------------------------------------------------------
9410       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9411       use comm_kut
9412 !      implicit real*8 (a-h,o-z)
9413 !      include 'DIMENSIONS'
9414 !      include 'COMMON.IOUNITS'
9415 !      include 'COMMON.CHAIN'
9416 !      include 'COMMON.DERIV'
9417 !      include 'COMMON.INTERACT'
9418 !      include 'COMMON.CONTACTS'
9419 !      include 'COMMON.TORSION'
9420 !      include 'COMMON.VAR'
9421 !      include 'COMMON.GEO'
9422       logical :: swap
9423       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9424       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9425 !el      logical :: lprn
9426 !el      common /kutas/ lprn
9427       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9428       real(kind=8) :: s2,s3,s4
9429 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9430 !                                                                              C
9431 !      Parallel       Antiparallel                                             C
9432 !                                                                              C
9433 !          o             o                                                     C
9434 !     \   /l\           /j\   /                                                C
9435 !      \ /   \         /   \ /                                                 C
9436 !       o| o |         | o |o                                                  C
9437 !     \ j|/k\|      \  |/k\|l                                                  C
9438 !      \ /   \       \ /   \                                                   C
9439 !       o             o                                                        C
9440 !       i             i                                                        C
9441 !                                                                              C
9442 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9443 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9444 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9445 !           but not in a cluster cumulant
9446 #ifdef MOMENT
9447       s1=dip(1,jj,i)*dip(1,kk,k)
9448 #endif
9449       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9450       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9451       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9452       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9453       call transpose2(EUg(1,1,k),auxmat(1,1))
9454       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9455       vv(1)=pizda(1,1)-pizda(2,2)
9456       vv(2)=pizda(1,2)+pizda(2,1)
9457       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9458 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9459 #ifdef MOMENT
9460       eello6_graph2=-(s1+s2+s3+s4)
9461 #else
9462       eello6_graph2=-(s2+s3+s4)
9463 #endif
9464 !      eello6_graph2=-s3
9465 ! Derivatives in gamma(i-1)
9466       if (i.gt.1) then
9467 #ifdef MOMENT
9468         s1=dipderg(1,jj,i)*dip(1,kk,k)
9469 #endif
9470         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9471         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9472         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9473         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9474 #ifdef MOMENT
9475         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9476 #else
9477         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9478 #endif
9479 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9480       endif
9481 ! Derivatives in gamma(k-1)
9482 #ifdef MOMENT
9483       s1=dip(1,jj,i)*dipderg(1,kk,k)
9484 #endif
9485       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9486       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9487       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9488       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9489       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9490       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9491       vv(1)=pizda(1,1)-pizda(2,2)
9492       vv(2)=pizda(1,2)+pizda(2,1)
9493       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9494 #ifdef MOMENT
9495       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9496 #else
9497       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9498 #endif
9499 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9500 ! Derivatives in gamma(j-1) or gamma(l-1)
9501       if (j.gt.1) then
9502 #ifdef MOMENT
9503         s1=dipderg(3,jj,i)*dip(1,kk,k)
9504 #endif
9505         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9506         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9507         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9508         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9509         vv(1)=pizda(1,1)-pizda(2,2)
9510         vv(2)=pizda(1,2)+pizda(2,1)
9511         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9512 #ifdef MOMENT
9513         if (swap) then
9514           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9515         else
9516           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9517         endif
9518 #endif
9519         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9520 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9521       endif
9522 ! Derivatives in gamma(l-1) or gamma(j-1)
9523       if (l.gt.1) then
9524 #ifdef MOMENT
9525         s1=dip(1,jj,i)*dipderg(3,kk,k)
9526 #endif
9527         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9528         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9529         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9530         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9531         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9532         vv(1)=pizda(1,1)-pizda(2,2)
9533         vv(2)=pizda(1,2)+pizda(2,1)
9534         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9535 #ifdef MOMENT
9536         if (swap) then
9537           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9538         else
9539           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9540         endif
9541 #endif
9542         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9543 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9544       endif
9545 ! Cartesian derivatives.
9546       if (lprn) then
9547         write (2,*) 'In eello6_graph2'
9548         do iii=1,2
9549           write (2,*) 'iii=',iii
9550           do kkk=1,5
9551             write (2,*) 'kkk=',kkk
9552             do jjj=1,2
9553               write (2,'(3(2f10.5),5x)') &
9554               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9555             enddo
9556           enddo
9557         enddo
9558       endif
9559       do iii=1,2
9560         do kkk=1,5
9561           do lll=1,3
9562 #ifdef MOMENT
9563             if (iii.eq.1) then
9564               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9565             else
9566               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9567             endif
9568 #endif
9569             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9570               auxvec(1))
9571             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9572             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9573               auxvec(1))
9574             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9575             call transpose2(EUg(1,1,k),auxmat(1,1))
9576             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9577               pizda(1,1))
9578             vv(1)=pizda(1,1)-pizda(2,2)
9579             vv(2)=pizda(1,2)+pizda(2,1)
9580             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9581 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9582 #ifdef MOMENT
9583             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9584 #else
9585             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9586 #endif
9587             if (swap) then
9588               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9589             else
9590               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9591             endif
9592           enddo
9593         enddo
9594       enddo
9595       return
9596       end function eello6_graph2
9597 !-----------------------------------------------------------------------------
9598       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9599 !      implicit real*8 (a-h,o-z)
9600 !      include 'DIMENSIONS'
9601 !      include 'COMMON.IOUNITS'
9602 !      include 'COMMON.CHAIN'
9603 !      include 'COMMON.DERIV'
9604 !      include 'COMMON.INTERACT'
9605 !      include 'COMMON.CONTACTS'
9606 !      include 'COMMON.TORSION'
9607 !      include 'COMMON.VAR'
9608 !      include 'COMMON.GEO'
9609       real(kind=8),dimension(2) :: vv,auxvec
9610       real(kind=8),dimension(2,2) :: pizda,auxmat
9611       logical :: swap
9612       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9613       real(kind=8) :: s1,s2,s3,s4
9614 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9615 !                                                                              C
9616 !      Parallel       Antiparallel                                             C
9617 !                                                                              C
9618 !          o             o                                                     C
9619 !         /l\   /   \   /j\                                                    C
9620 !        /   \ /     \ /   \                                                   C
9621 !       /| o |o       o| o |\                                                  C
9622 !       j|/k\|  /      |/k\|l /                                                C
9623 !        /   \ /       /   \ /                                                 C
9624 !       /     o       /     o                                                  C
9625 !       i             i                                                        C
9626 !                                                                              C
9627 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9628 !
9629 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9630 !           energy moment and not to the cluster cumulant.
9631       iti=itortyp(itype(i,1))
9632       if (j.lt.nres-1) then
9633         itj1=itortyp(itype(j+1,1))
9634       else
9635         itj1=ntortyp+1
9636       endif
9637       itk=itortyp(itype(k,1))
9638       itk1=itortyp(itype(k+1,1))
9639       if (l.lt.nres-1) then
9640         itl1=itortyp(itype(l+1,1))
9641       else
9642         itl1=ntortyp+1
9643       endif
9644 #ifdef MOMENT
9645       s1=dip(4,jj,i)*dip(4,kk,k)
9646 #endif
9647       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9648       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9649       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9650       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9651       call transpose2(EE(1,1,itk),auxmat(1,1))
9652       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9653       vv(1)=pizda(1,1)+pizda(2,2)
9654       vv(2)=pizda(2,1)-pizda(1,2)
9655       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9656 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9657 !d     & "sum",-(s2+s3+s4)
9658 #ifdef MOMENT
9659       eello6_graph3=-(s1+s2+s3+s4)
9660 #else
9661       eello6_graph3=-(s2+s3+s4)
9662 #endif
9663 !      eello6_graph3=-s4
9664 ! Derivatives in gamma(k-1)
9665       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9666       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9667       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9668       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9669 ! Derivatives in gamma(l-1)
9670       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9671       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9672       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9673       vv(1)=pizda(1,1)+pizda(2,2)
9674       vv(2)=pizda(2,1)-pizda(1,2)
9675       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9676       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9677 ! Cartesian derivatives.
9678       do iii=1,2
9679         do kkk=1,5
9680           do lll=1,3
9681 #ifdef MOMENT
9682             if (iii.eq.1) then
9683               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9684             else
9685               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9686             endif
9687 #endif
9688             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9689               auxvec(1))
9690             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9691             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9692               auxvec(1))
9693             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9694             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9695               pizda(1,1))
9696             vv(1)=pizda(1,1)+pizda(2,2)
9697             vv(2)=pizda(2,1)-pizda(1,2)
9698             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9699 #ifdef MOMENT
9700             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9701 #else
9702             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9703 #endif
9704             if (swap) then
9705               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9706             else
9707               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9708             endif
9709 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9710           enddo
9711         enddo
9712       enddo
9713       return
9714       end function eello6_graph3
9715 !-----------------------------------------------------------------------------
9716       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9717 !      implicit real*8 (a-h,o-z)
9718 !      include 'DIMENSIONS'
9719 !      include 'COMMON.IOUNITS'
9720 !      include 'COMMON.CHAIN'
9721 !      include 'COMMON.DERIV'
9722 !      include 'COMMON.INTERACT'
9723 !      include 'COMMON.CONTACTS'
9724 !      include 'COMMON.TORSION'
9725 !      include 'COMMON.VAR'
9726 !      include 'COMMON.GEO'
9727 !      include 'COMMON.FFIELD'
9728       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9729       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9730       logical :: swap
9731       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9732               iii,kkk,lll
9733       real(kind=8) :: s1,s2,s3,s4
9734 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9735 !                                                                              C
9736 !      Parallel       Antiparallel                                             C
9737 !                                                                              C
9738 !          o             o                                                     C
9739 !         /l\   /   \   /j\                                                    C
9740 !        /   \ /     \ /   \                                                   C
9741 !       /| o |o       o| o |\                                                  C
9742 !     \ j|/k\|      \  |/k\|l                                                  C
9743 !      \ /   \       \ /   \                                                   C
9744 !       o     \       o     \                                                  C
9745 !       i             i                                                        C
9746 !                                                                              C
9747 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9748 !
9749 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9750 !           energy moment and not to the cluster cumulant.
9751 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9752       iti=itortyp(itype(i,1))
9753       itj=itortyp(itype(j,1))
9754       if (j.lt.nres-1) then
9755         itj1=itortyp(itype(j+1,1))
9756       else
9757         itj1=ntortyp+1
9758       endif
9759       itk=itortyp(itype(k,1))
9760       if (k.lt.nres-1) then
9761         itk1=itortyp(itype(k+1,1))
9762       else
9763         itk1=ntortyp+1
9764       endif
9765       itl=itortyp(itype(l,1))
9766       if (l.lt.nres-1) then
9767         itl1=itortyp(itype(l+1,1))
9768       else
9769         itl1=ntortyp+1
9770       endif
9771 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9772 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9773 !d     & ' itl',itl,' itl1',itl1
9774 #ifdef MOMENT
9775       if (imat.eq.1) then
9776         s1=dip(3,jj,i)*dip(3,kk,k)
9777       else
9778         s1=dip(2,jj,j)*dip(2,kk,l)
9779       endif
9780 #endif
9781       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9782       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9783       if (j.eq.l+1) then
9784         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9785         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9786       else
9787         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9788         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9789       endif
9790       call transpose2(EUg(1,1,k),auxmat(1,1))
9791       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9792       vv(1)=pizda(1,1)-pizda(2,2)
9793       vv(2)=pizda(2,1)+pizda(1,2)
9794       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9795 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9796 #ifdef MOMENT
9797       eello6_graph4=-(s1+s2+s3+s4)
9798 #else
9799       eello6_graph4=-(s2+s3+s4)
9800 #endif
9801 ! Derivatives in gamma(i-1)
9802       if (i.gt.1) then
9803 #ifdef MOMENT
9804         if (imat.eq.1) then
9805           s1=dipderg(2,jj,i)*dip(3,kk,k)
9806         else
9807           s1=dipderg(4,jj,j)*dip(2,kk,l)
9808         endif
9809 #endif
9810         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9811         if (j.eq.l+1) then
9812           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9813           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9814         else
9815           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9816           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9817         endif
9818         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9819         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9820 !d          write (2,*) 'turn6 derivatives'
9821 #ifdef MOMENT
9822           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9823 #else
9824           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9825 #endif
9826         else
9827 #ifdef MOMENT
9828           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9829 #else
9830           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9831 #endif
9832         endif
9833       endif
9834 ! Derivatives in gamma(k-1)
9835 #ifdef MOMENT
9836       if (imat.eq.1) then
9837         s1=dip(3,jj,i)*dipderg(2,kk,k)
9838       else
9839         s1=dip(2,jj,j)*dipderg(4,kk,l)
9840       endif
9841 #endif
9842       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9843       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9844       if (j.eq.l+1) then
9845         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9846         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9847       else
9848         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9849         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9850       endif
9851       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9852       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9853       vv(1)=pizda(1,1)-pizda(2,2)
9854       vv(2)=pizda(2,1)+pizda(1,2)
9855       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9856       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9857 #ifdef MOMENT
9858         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9859 #else
9860         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9861 #endif
9862       else
9863 #ifdef MOMENT
9864         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9865 #else
9866         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9867 #endif
9868       endif
9869 ! Derivatives in gamma(j-1) or gamma(l-1)
9870       if (l.eq.j+1 .and. l.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         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9878       else if (j.gt.1) then
9879         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9880         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9881         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9882         vv(1)=pizda(1,1)-pizda(2,2)
9883         vv(2)=pizda(2,1)+pizda(1,2)
9884         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9885         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9886           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9887         else
9888           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9889         endif
9890       endif
9891 ! Cartesian derivatives.
9892       do iii=1,2
9893         do kkk=1,5
9894           do lll=1,3
9895 #ifdef MOMENT
9896             if (iii.eq.1) then
9897               if (imat.eq.1) then
9898                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9899               else
9900                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9901               endif
9902             else
9903               if (imat.eq.1) then
9904                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9905               else
9906                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9907               endif
9908             endif
9909 #endif
9910             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9911               auxvec(1))
9912             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9913             if (j.eq.l+1) then
9914               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9915                 b1(1,itj1),auxvec(1))
9916               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9917             else
9918               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9919                 b1(1,itl1),auxvec(1))
9920               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9921             endif
9922             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9923               pizda(1,1))
9924             vv(1)=pizda(1,1)-pizda(2,2)
9925             vv(2)=pizda(2,1)+pizda(1,2)
9926             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9927             if (swap) then
9928               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9929 #ifdef MOMENT
9930                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9931                    -(s1+s2+s4)
9932 #else
9933                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9934                    -(s2+s4)
9935 #endif
9936                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9937               else
9938 #ifdef MOMENT
9939                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9940 #else
9941                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9942 #endif
9943                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9944               endif
9945             else
9946 #ifdef MOMENT
9947               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9948 #else
9949               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9950 #endif
9951               if (l.eq.j+1) then
9952                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9953               else
9954                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9955               endif
9956             endif
9957           enddo
9958         enddo
9959       enddo
9960       return
9961       end function eello6_graph4
9962 !-----------------------------------------------------------------------------
9963       real(kind=8) function eello_turn6(i,jj,kk)
9964 !      implicit real*8 (a-h,o-z)
9965 !      include 'DIMENSIONS'
9966 !      include 'COMMON.IOUNITS'
9967 !      include 'COMMON.CHAIN'
9968 !      include 'COMMON.DERIV'
9969 !      include 'COMMON.INTERACT'
9970 !      include 'COMMON.CONTACTS'
9971 !      include 'COMMON.TORSION'
9972 !      include 'COMMON.VAR'
9973 !      include 'COMMON.GEO'
9974       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9975       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9976       real(kind=8),dimension(3) :: ggg1,ggg2
9977       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9978       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9979 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9980 !           the respective energy moment and not to the cluster cumulant.
9981 !el local variables
9982       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9983       integer :: j1,j2,l1,l2,ll
9984       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9985       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9986       s1=0.0d0
9987       s8=0.0d0
9988       s13=0.0d0
9989 !
9990       eello_turn6=0.0d0
9991       j=i+4
9992       k=i+1
9993       l=i+3
9994       iti=itortyp(itype(i,1))
9995       itk=itortyp(itype(k,1))
9996       itk1=itortyp(itype(k+1,1))
9997       itl=itortyp(itype(l,1))
9998       itj=itortyp(itype(j,1))
9999 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10000 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10001 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10002 !d        eello6=0.0d0
10003 !d        return
10004 !d      endif
10005 !d      write (iout,*)
10006 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10007 !d     &   ' and',k,l
10008 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10009       do iii=1,2
10010         do kkk=1,5
10011           do lll=1,3
10012             derx_turn(lll,kkk,iii)=0.0d0
10013           enddo
10014         enddo
10015       enddo
10016 !d      eij=1.0d0
10017 !d      ekl=1.0d0
10018 !d      ekont=1.0d0
10019       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10020 !d      eello6_5=0.0d0
10021 !d      write (2,*) 'eello6_5',eello6_5
10022 #ifdef MOMENT
10023       call transpose2(AEA(1,1,1),auxmat(1,1))
10024       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10025       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10026       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10027 #endif
10028       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10029       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10030       s2 = scalar2(b1(1,itk),vtemp1(1))
10031 #ifdef MOMENT
10032       call transpose2(AEA(1,1,2),atemp(1,1))
10033       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10034       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10035       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10036 #endif
10037       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10038       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10039       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10040 #ifdef MOMENT
10041       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10042       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10043       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10044       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10045       ss13 = scalar2(b1(1,itk),vtemp4(1))
10046       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10047 #endif
10048 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10049 !      s1=0.0d0
10050 !      s2=0.0d0
10051 !      s8=0.0d0
10052 !      s12=0.0d0
10053 !      s13=0.0d0
10054       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10055 ! Derivatives in gamma(i+2)
10056       s1d =0.0d0
10057       s8d =0.0d0
10058 #ifdef MOMENT
10059       call transpose2(AEA(1,1,1),auxmatd(1,1))
10060       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10061       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10062       call transpose2(AEAderg(1,1,2),atempd(1,1))
10063       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10064       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10065 #endif
10066       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10067       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10068       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10069 !      s1d=0.0d0
10070 !      s2d=0.0d0
10071 !      s8d=0.0d0
10072 !      s12d=0.0d0
10073 !      s13d=0.0d0
10074       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10075 ! Derivatives in gamma(i+3)
10076 #ifdef MOMENT
10077       call transpose2(AEA(1,1,1),auxmatd(1,1))
10078       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10079       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10080       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10081 #endif
10082       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10083       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10084       s2d = scalar2(b1(1,itk),vtemp1d(1))
10085 #ifdef MOMENT
10086       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10087       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10088 #endif
10089       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10090 #ifdef MOMENT
10091       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10092       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10093       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10094 #endif
10095 !      s1d=0.0d0
10096 !      s2d=0.0d0
10097 !      s8d=0.0d0
10098 !      s12d=0.0d0
10099 !      s13d=0.0d0
10100 #ifdef MOMENT
10101       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10102                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10103 #else
10104       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10105                     -0.5d0*ekont*(s2d+s12d)
10106 #endif
10107 ! Derivatives in gamma(i+4)
10108       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10109       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10110       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10111 #ifdef MOMENT
10112       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10113       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10114       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10115 #endif
10116 !      s1d=0.0d0
10117 !      s2d=0.0d0
10118 !      s8d=0.0d0
10119 !      s12d=0.0d0
10120 !      s13d=0.0d0
10121 #ifdef MOMENT
10122       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10123 #else
10124       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10125 #endif
10126 ! Derivatives in gamma(i+5)
10127 #ifdef MOMENT
10128       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10129       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10130       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10131 #endif
10132       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10133       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10134       s2d = scalar2(b1(1,itk),vtemp1d(1))
10135 #ifdef MOMENT
10136       call transpose2(AEA(1,1,2),atempd(1,1))
10137       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10138       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10139 #endif
10140       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10141       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10142 #ifdef MOMENT
10143       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10144       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10145       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10146 #endif
10147 !      s1d=0.0d0
10148 !      s2d=0.0d0
10149 !      s8d=0.0d0
10150 !      s12d=0.0d0
10151 !      s13d=0.0d0
10152 #ifdef MOMENT
10153       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10154                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10155 #else
10156       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10157                     -0.5d0*ekont*(s2d+s12d)
10158 #endif
10159 ! Cartesian derivatives
10160       do iii=1,2
10161         do kkk=1,5
10162           do lll=1,3
10163 #ifdef MOMENT
10164             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10165             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10166             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10167 #endif
10168             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10169             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10170                 vtemp1d(1))
10171             s2d = scalar2(b1(1,itk),vtemp1d(1))
10172 #ifdef MOMENT
10173             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10174             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10175             s8d = -(atempd(1,1)+atempd(2,2))* &
10176                  scalar2(cc(1,1,itl),vtemp2(1))
10177 #endif
10178             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10179                  auxmatd(1,1))
10180             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10181             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10182 !      s1d=0.0d0
10183 !      s2d=0.0d0
10184 !      s8d=0.0d0
10185 !      s12d=0.0d0
10186 !      s13d=0.0d0
10187 #ifdef MOMENT
10188             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10189               - 0.5d0*(s1d+s2d)
10190 #else
10191             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10192               - 0.5d0*s2d
10193 #endif
10194 #ifdef MOMENT
10195             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10196               - 0.5d0*(s8d+s12d)
10197 #else
10198             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10199               - 0.5d0*s12d
10200 #endif
10201           enddo
10202         enddo
10203       enddo
10204 #ifdef MOMENT
10205       do kkk=1,5
10206         do lll=1,3
10207           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10208             achuj_tempd(1,1))
10209           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10210           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10211           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10212           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10213           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10214             vtemp4d(1))
10215           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10216           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10217           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10218         enddo
10219       enddo
10220 #endif
10221 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10222 !d     &  16*eel_turn6_num
10223 !d      goto 1112
10224       if (j.lt.nres-1) then
10225         j1=j+1
10226         j2=j-1
10227       else
10228         j1=j-1
10229         j2=j-2
10230       endif
10231       if (l.lt.nres-1) then
10232         l1=l+1
10233         l2=l-1
10234       else
10235         l1=l-1
10236         l2=l-2
10237       endif
10238       do ll=1,3
10239 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10240 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10241 !grad        ghalf=0.5d0*ggg1(ll)
10242 !d        ghalf=0.0d0
10243         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10244         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10245         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10246           +ekont*derx_turn(ll,2,1)
10247         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10248         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10249           +ekont*derx_turn(ll,4,1)
10250         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10251         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10252         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10253 !grad        ghalf=0.5d0*ggg2(ll)
10254 !d        ghalf=0.0d0
10255         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10256           +ekont*derx_turn(ll,2,2)
10257         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10258         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10259           +ekont*derx_turn(ll,4,2)
10260         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10261         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10262         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10263       enddo
10264 !d      goto 1112
10265 !grad      do m=i+1,j-1
10266 !grad        do ll=1,3
10267 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10268 !grad        enddo
10269 !grad      enddo
10270 !grad      do m=k+1,l-1
10271 !grad        do ll=1,3
10272 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10273 !grad        enddo
10274 !grad      enddo
10275 !grad1112  continue
10276 !grad      do m=i+2,j2
10277 !grad        do ll=1,3
10278 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10279 !grad        enddo
10280 !grad      enddo
10281 !grad      do m=k+2,l2
10282 !grad        do ll=1,3
10283 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10284 !grad        enddo
10285 !grad      enddo
10286 !d      do iii=1,nres-3
10287 !d        write (2,*) iii,g_corr6_loc(iii)
10288 !d      enddo
10289       eello_turn6=ekont*eel_turn6
10290 !d      write (2,*) 'ekont',ekont
10291 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10292       return
10293       end function eello_turn6
10294 !-----------------------------------------------------------------------------
10295       subroutine MATVEC2(A1,V1,V2)
10296 !DIR$ INLINEALWAYS MATVEC2
10297 #ifndef OSF
10298 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10299 #endif
10300 !      implicit real*8 (a-h,o-z)
10301 !      include 'DIMENSIONS'
10302       real(kind=8),dimension(2) :: V1,V2
10303       real(kind=8),dimension(2,2) :: A1
10304       real(kind=8) :: vaux1,vaux2
10305 !      DO 1 I=1,2
10306 !        VI=0.0
10307 !        DO 3 K=1,2
10308 !    3     VI=VI+A1(I,K)*V1(K)
10309 !        Vaux(I)=VI
10310 !    1 CONTINUE
10311
10312       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10313       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10314
10315       v2(1)=vaux1
10316       v2(2)=vaux2
10317       end subroutine MATVEC2
10318 !-----------------------------------------------------------------------------
10319       subroutine MATMAT2(A1,A2,A3)
10320 #ifndef OSF
10321 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10322 #endif
10323 !      implicit real*8 (a-h,o-z)
10324 !      include 'DIMENSIONS'
10325       real(kind=8),dimension(2,2) :: A1,A2,A3
10326       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10327 !      DIMENSION AI3(2,2)
10328 !        DO  J=1,2
10329 !          A3IJ=0.0
10330 !          DO K=1,2
10331 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10332 !          enddo
10333 !          A3(I,J)=A3IJ
10334 !       enddo
10335 !      enddo
10336
10337       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10338       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10339       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10340       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10341
10342       A3(1,1)=AI3_11
10343       A3(2,1)=AI3_21
10344       A3(1,2)=AI3_12
10345       A3(2,2)=AI3_22
10346       end subroutine MATMAT2
10347 !-----------------------------------------------------------------------------
10348       real(kind=8) function scalar2(u,v)
10349 !DIR$ INLINEALWAYS scalar2
10350       implicit none
10351       real(kind=8),dimension(2) :: u,v
10352       real(kind=8) :: sc
10353       integer :: i
10354       scalar2=u(1)*v(1)+u(2)*v(2)
10355       return
10356       end function scalar2
10357 !-----------------------------------------------------------------------------
10358       subroutine transpose2(a,at)
10359 !DIR$ INLINEALWAYS transpose2
10360 #ifndef OSF
10361 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10362 #endif
10363       implicit none
10364       real(kind=8),dimension(2,2) :: a,at
10365       at(1,1)=a(1,1)
10366       at(1,2)=a(2,1)
10367       at(2,1)=a(1,2)
10368       at(2,2)=a(2,2)
10369       return
10370       end subroutine transpose2
10371 !-----------------------------------------------------------------------------
10372       subroutine transpose(n,a,at)
10373       implicit none
10374       integer :: n,i,j
10375       real(kind=8),dimension(n,n) :: a,at
10376       do i=1,n
10377         do j=1,n
10378           at(j,i)=a(i,j)
10379         enddo
10380       enddo
10381       return
10382       end subroutine transpose
10383 !-----------------------------------------------------------------------------
10384       subroutine prodmat3(a1,a2,kk,transp,prod)
10385 !DIR$ INLINEALWAYS prodmat3
10386 #ifndef OSF
10387 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10388 #endif
10389       implicit none
10390       integer :: i,j
10391       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10392       logical :: transp
10393 !rc      double precision auxmat(2,2),prod_(2,2)
10394
10395       if (transp) then
10396 !rc        call transpose2(kk(1,1),auxmat(1,1))
10397 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10398 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10399
10400            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10401        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10402            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10403        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10404            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10405        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10406            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10407        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10408
10409       else
10410 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10411 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10412
10413            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10414         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10415            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10416         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10417            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10418         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10419            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10420         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10421
10422       endif
10423 !      call transpose2(a2(1,1),a2t(1,1))
10424
10425 !rc      print *,transp
10426 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10427 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10428
10429       return
10430       end subroutine prodmat3
10431 !-----------------------------------------------------------------------------
10432 ! energy_p_new_barrier.F
10433 !-----------------------------------------------------------------------------
10434       subroutine sum_gradient
10435 !      implicit real*8 (a-h,o-z)
10436       use io_base, only: pdbout
10437 !      include 'DIMENSIONS'
10438 #ifndef ISNAN
10439       external proc_proc
10440 #ifdef WINPGI
10441 !MS$ATTRIBUTES C ::  proc_proc
10442 #endif
10443 #endif
10444 #ifdef MPI
10445       include 'mpif.h'
10446 #endif
10447       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10448                    gloc_scbuf !(3,maxres)
10449
10450       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10451 !#endif
10452 !el local variables
10453       integer :: i,j,k,ierror,ierr
10454       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10455                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10456                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10457                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10458                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10459                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10460                    gsccorr_max,gsccorrx_max,time00
10461
10462 !      include 'COMMON.SETUP'
10463 !      include 'COMMON.IOUNITS'
10464 !      include 'COMMON.FFIELD'
10465 !      include 'COMMON.DERIV'
10466 !      include 'COMMON.INTERACT'
10467 !      include 'COMMON.SBRIDGE'
10468 !      include 'COMMON.CHAIN'
10469 !      include 'COMMON.VAR'
10470 !      include 'COMMON.CONTROL'
10471 !      include 'COMMON.TIME1'
10472 !      include 'COMMON.MAXGRAD'
10473 !      include 'COMMON.SCCOR'
10474 #ifdef TIMING
10475       time01=MPI_Wtime()
10476 #endif
10477 #ifdef DEBUG
10478       write (iout,*) "sum_gradient gvdwc, gvdwx"
10479       do i=1,nres
10480         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10481          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10482       enddo
10483       call flush(iout)
10484 #endif
10485 #ifdef MPI
10486         gradbufc=0.0d0
10487         gradbufx=0.0d0
10488         gradbufc_sum=0.0d0
10489         gloc_scbuf=0.0d0
10490         glocbuf=0.0d0
10491 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10492         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10493           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10494 #endif
10495 !
10496 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10497 !            in virtual-bond-vector coordinates
10498 !
10499 #ifdef DEBUG
10500 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10501 !      do i=1,nres-1
10502 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10503 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10504 !      enddo
10505 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10506 !      do i=1,nres-1
10507 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10508 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10509 !      enddo
10510       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10511       do i=1,nres
10512         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10513          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10514          (gvdwc_scpp(j,i),j=1,3)
10515       enddo
10516       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10517       do i=1,nres
10518         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10519          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10520          (gelc_loc_long(j,i),j=1,3)
10521       enddo
10522       call flush(iout)
10523 #endif
10524 #ifdef SPLITELE
10525       do i=0,nct
10526         do j=1,3
10527           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10528                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10529                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10530                       wel_loc*gel_loc_long(j,i)+ &
10531                       wcorr*gradcorr_long(j,i)+ &
10532                       wcorr5*gradcorr5_long(j,i)+ &
10533                       wcorr6*gradcorr6_long(j,i)+ &
10534                       wturn6*gcorr6_turn_long(j,i)+ &
10535                       wstrain*ghpbc(j,i) &
10536                      +wliptran*gliptranc(j,i) &
10537                      +gradafm(j,i) &
10538                      +welec*gshieldc(j,i) &
10539                      +wcorr*gshieldc_ec(j,i) &
10540                      +wturn3*gshieldc_t3(j,i)&
10541                      +wturn4*gshieldc_t4(j,i)&
10542                      +wel_loc*gshieldc_ll(j,i)&
10543                      +wtube*gg_tube(j,i) &
10544                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10545                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10546                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10547                      wcorr_nucl*gradcorr_nucl(j,i)&
10548                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10549                      wcatprot* gradpepcat(j,i)+ &
10550                      wcatcat*gradcatcat(j,i)+   &
10551                      wscbase*gvdwc_scbase(j,i)+ &
10552                      wpepbase*gvdwc_pepbase(j,i)+&
10553                      wscpho*gvdwc_scpho(j,i)+   &
10554                      wpeppho*gvdwc_peppho(j,i)
10555
10556
10557
10558
10559
10560         enddo
10561       enddo
10562 #else
10563       do i=0,nct
10564         do j=1,3
10565           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10566                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10567                       welec*gelc_long(j,i)+ &
10568                       wbond*gradb(j,i)+ &
10569                       wel_loc*gel_loc_long(j,i)+ &
10570                       wcorr*gradcorr_long(j,i)+ &
10571                       wcorr5*gradcorr5_long(j,i)+ &
10572                       wcorr6*gradcorr6_long(j,i)+ &
10573                       wturn6*gcorr6_turn_long(j,i)+ &
10574                       wstrain*ghpbc(j,i) &
10575                      +wliptran*gliptranc(j,i) &
10576                      +gradafm(j,i) &
10577                      +welec*gshieldc(j,i)&
10578                      +wcorr*gshieldc_ec(j,i) &
10579                      +wturn4*gshieldc_t4(j,i) &
10580                      +wel_loc*gshieldc_ll(j,i)&
10581                      +wtube*gg_tube(j,i) &
10582                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10583                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10584                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10585                      wcorr_nucl*gradcorr_nucl(j,i) &
10586                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10587                      wcatprot* gradpepcat(j,i)+ &
10588                      wcatcat*gradcatcat(j,i)+   &
10589                      wscbase*gvdwc_scbase(j,i)  &
10590                      wpepbase*gvdwc_pepbase(j,i)+&
10591                      wscpho*gvdwc_scpho(j,i)+&
10592                      wpeppho*gvdwc_peppho(j,i)
10593
10594
10595         enddo
10596       enddo
10597 #endif
10598 #ifdef MPI
10599       if (nfgtasks.gt.1) then
10600       time00=MPI_Wtime()
10601 #ifdef DEBUG
10602       write (iout,*) "gradbufc before allreduce"
10603       do i=1,nres
10604         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10605       enddo
10606       call flush(iout)
10607 #endif
10608       do i=0,nres
10609         do j=1,3
10610           gradbufc_sum(j,i)=gradbufc(j,i)
10611         enddo
10612       enddo
10613 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10614 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10615 !      time_reduce=time_reduce+MPI_Wtime()-time00
10616 #ifdef DEBUG
10617 !      write (iout,*) "gradbufc_sum after allreduce"
10618 !      do i=1,nres
10619 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10620 !      enddo
10621 !      call flush(iout)
10622 #endif
10623 #ifdef TIMING
10624 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10625 #endif
10626       do i=0,nres
10627         do k=1,3
10628           gradbufc(k,i)=0.0d0
10629         enddo
10630       enddo
10631 #ifdef DEBUG
10632       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10633       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10634                         " jgrad_end  ",jgrad_end(i),&
10635                         i=igrad_start,igrad_end)
10636 #endif
10637 !
10638 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10639 ! do not parallelize this part.
10640 !
10641 !      do i=igrad_start,igrad_end
10642 !        do j=jgrad_start(i),jgrad_end(i)
10643 !          do k=1,3
10644 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10645 !          enddo
10646 !        enddo
10647 !      enddo
10648       do j=1,3
10649         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10650       enddo
10651       do i=nres-2,-1,-1
10652         do j=1,3
10653           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10654         enddo
10655       enddo
10656 #ifdef DEBUG
10657       write (iout,*) "gradbufc after summing"
10658       do i=1,nres
10659         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10660       enddo
10661       call flush(iout)
10662 #endif
10663       else
10664 #endif
10665 !el#define DEBUG
10666 #ifdef DEBUG
10667       write (iout,*) "gradbufc"
10668       do i=1,nres
10669         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10670       enddo
10671       call flush(iout)
10672 #endif
10673 !el#undef DEBUG
10674       do i=-1,nres
10675         do j=1,3
10676           gradbufc_sum(j,i)=gradbufc(j,i)
10677           gradbufc(j,i)=0.0d0
10678         enddo
10679       enddo
10680       do j=1,3
10681         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10682       enddo
10683       do i=nres-2,-1,-1
10684         do j=1,3
10685           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10686         enddo
10687       enddo
10688 !      do i=nnt,nres-1
10689 !        do k=1,3
10690 !          gradbufc(k,i)=0.0d0
10691 !        enddo
10692 !        do j=i+1,nres
10693 !          do k=1,3
10694 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10695 !          enddo
10696 !        enddo
10697 !      enddo
10698 !el#define DEBUG
10699 #ifdef DEBUG
10700       write (iout,*) "gradbufc after summing"
10701       do i=1,nres
10702         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10703       enddo
10704       call flush(iout)
10705 #endif
10706 !el#undef DEBUG
10707 #ifdef MPI
10708       endif
10709 #endif
10710       do k=1,3
10711         gradbufc(k,nres)=0.0d0
10712       enddo
10713 !el----------------
10714 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10715 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10716 !el-----------------
10717       do i=-1,nct
10718         do j=1,3
10719 #ifdef SPLITELE
10720           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10721                       wel_loc*gel_loc(j,i)+ &
10722                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10723                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10724                       wel_loc*gel_loc_long(j,i)+ &
10725                       wcorr*gradcorr_long(j,i)+ &
10726                       wcorr5*gradcorr5_long(j,i)+ &
10727                       wcorr6*gradcorr6_long(j,i)+ &
10728                       wturn6*gcorr6_turn_long(j,i))+ &
10729                       wbond*gradb(j,i)+ &
10730                       wcorr*gradcorr(j,i)+ &
10731                       wturn3*gcorr3_turn(j,i)+ &
10732                       wturn4*gcorr4_turn(j,i)+ &
10733                       wcorr5*gradcorr5(j,i)+ &
10734                       wcorr6*gradcorr6(j,i)+ &
10735                       wturn6*gcorr6_turn(j,i)+ &
10736                       wsccor*gsccorc(j,i) &
10737                      +wscloc*gscloc(j,i)  &
10738                      +wliptran*gliptranc(j,i) &
10739                      +gradafm(j,i) &
10740                      +welec*gshieldc(j,i) &
10741                      +welec*gshieldc_loc(j,i) &
10742                      +wcorr*gshieldc_ec(j,i) &
10743                      +wcorr*gshieldc_loc_ec(j,i) &
10744                      +wturn3*gshieldc_t3(j,i) &
10745                      +wturn3*gshieldc_loc_t3(j,i) &
10746                      +wturn4*gshieldc_t4(j,i) &
10747                      +wturn4*gshieldc_loc_t4(j,i) &
10748                      +wel_loc*gshieldc_ll(j,i) &
10749                      +wel_loc*gshieldc_loc_ll(j,i) &
10750                      +wtube*gg_tube(j,i) &
10751                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10752                      +wvdwpsb*gvdwpsb1(j,i))&
10753                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10754
10755 !                 if ((i.le.2).and.(i.ge.1))
10756 !                       print *,gradc(j,i,icg),&
10757 !                      gradbufc(j,i),welec*gelc(j,i), &
10758 !                      wel_loc*gel_loc(j,i), &
10759 !                      wscp*gvdwc_scpp(j,i), &
10760 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10761 !                      wel_loc*gel_loc_long(j,i), &
10762 !                      wcorr*gradcorr_long(j,i), &
10763 !                      wcorr5*gradcorr5_long(j,i), &
10764 !                      wcorr6*gradcorr6_long(j,i), &
10765 !                      wturn6*gcorr6_turn_long(j,i), &
10766 !                      wbond*gradb(j,i), &
10767 !                      wcorr*gradcorr(j,i), &
10768 !                      wturn3*gcorr3_turn(j,i), &
10769 !                      wturn4*gcorr4_turn(j,i), &
10770 !                      wcorr5*gradcorr5(j,i), &
10771 !                      wcorr6*gradcorr6(j,i), &
10772 !                      wturn6*gcorr6_turn(j,i), &
10773 !                      wsccor*gsccorc(j,i) &
10774 !                     ,wscloc*gscloc(j,i)  &
10775 !                     ,wliptran*gliptranc(j,i) &
10776 !                    ,gradafm(j,i) &
10777 !                     ,welec*gshieldc(j,i) &
10778 !                     ,welec*gshieldc_loc(j,i) &
10779 !                     ,wcorr*gshieldc_ec(j,i) &
10780 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10781 !                     ,wturn3*gshieldc_t3(j,i) &
10782 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10783 !                     ,wturn4*gshieldc_t4(j,i) &
10784 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10785 !                     ,wel_loc*gshieldc_ll(j,i) &
10786 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10787 !                     ,wtube*gg_tube(j,i) &
10788 !                     ,wbond_nucl*gradb_nucl(j,i) &
10789 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10790 !                     wvdwpsb*gvdwpsb1(j,i)&
10791 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10792 !
10793
10794 #else
10795           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10796                       wel_loc*gel_loc(j,i)+ &
10797                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10798                       welec*gelc_long(j,i)+ &
10799                       wel_loc*gel_loc_long(j,i)+ &
10800 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10801                       wcorr5*gradcorr5_long(j,i)+ &
10802                       wcorr6*gradcorr6_long(j,i)+ &
10803                       wturn6*gcorr6_turn_long(j,i))+ &
10804                       wbond*gradb(j,i)+ &
10805                       wcorr*gradcorr(j,i)+ &
10806                       wturn3*gcorr3_turn(j,i)+ &
10807                       wturn4*gcorr4_turn(j,i)+ &
10808                       wcorr5*gradcorr5(j,i)+ &
10809                       wcorr6*gradcorr6(j,i)+ &
10810                       wturn6*gcorr6_turn(j,i)+ &
10811                       wsccor*gsccorc(j,i) &
10812                      +wscloc*gscloc(j,i) &
10813                      +gradafm(j,i) &
10814                      +wliptran*gliptranc(j,i) &
10815                      +welec*gshieldc(j,i) &
10816                      +welec*gshieldc_loc(j,) &
10817                      +wcorr*gshieldc_ec(j,i) &
10818                      +wcorr*gshieldc_loc_ec(j,i) &
10819                      +wturn3*gshieldc_t3(j,i) &
10820                      +wturn3*gshieldc_loc_t3(j,i) &
10821                      +wturn4*gshieldc_t4(j,i) &
10822                      +wturn4*gshieldc_loc_t4(j,i) &
10823                      +wel_loc*gshieldc_ll(j,i) &
10824                      +wel_loc*gshieldc_loc_ll(j,i) &
10825                      +wtube*gg_tube(j,i) &
10826                      +wbond_nucl*gradb_nucl(j,i) &
10827                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10828                      +wvdwpsb*gvdwpsb1(j,i))&
10829                      +wsbloc*gsbloc(j,i)
10830
10831
10832
10833
10834 #endif
10835           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10836                         wbond*gradbx(j,i)+ &
10837                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10838                         wsccor*gsccorx(j,i) &
10839                        +wscloc*gsclocx(j,i) &
10840                        +wliptran*gliptranx(j,i) &
10841                        +welec*gshieldx(j,i)     &
10842                        +wcorr*gshieldx_ec(j,i)  &
10843                        +wturn3*gshieldx_t3(j,i) &
10844                        +wturn4*gshieldx_t4(j,i) &
10845                        +wel_loc*gshieldx_ll(j,i)&
10846                        +wtube*gg_tube_sc(j,i)   &
10847                        +wbond_nucl*gradbx_nucl(j,i) &
10848                        +wvdwsb*gvdwsbx(j,i) &
10849                        +welsb*gelsbx(j,i) &
10850                        +wcorr_nucl*gradxorr_nucl(j,i)&
10851                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10852                        +wsbloc*gsblocx(j,i) &
10853                        +wcatprot* gradpepcatx(j,i)&
10854                        +wscbase*gvdwx_scbase(j,i) &
10855                        +wpepbase*gvdwx_pepbase(j,i)&
10856                        +wscpho*gvdwx_scpho(j,i)
10857 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
10858
10859         enddo
10860       enddo
10861 #ifdef DEBUG
10862       write (iout,*) "gloc before adding corr"
10863       do i=1,4*nres
10864         write (iout,*) i,gloc(i,icg)
10865       enddo
10866 #endif
10867       do i=1,nres-3
10868         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10869          +wcorr5*g_corr5_loc(i) &
10870          +wcorr6*g_corr6_loc(i) &
10871          +wturn4*gel_loc_turn4(i) &
10872          +wturn3*gel_loc_turn3(i) &
10873          +wturn6*gel_loc_turn6(i) &
10874          +wel_loc*gel_loc_loc(i)
10875       enddo
10876 #ifdef DEBUG
10877       write (iout,*) "gloc after adding corr"
10878       do i=1,4*nres
10879         write (iout,*) i,gloc(i,icg)
10880       enddo
10881 #endif
10882 #ifdef MPI
10883       if (nfgtasks.gt.1) then
10884         do j=1,3
10885           do i=0,nres
10886             gradbufc(j,i)=gradc(j,i,icg)
10887             gradbufx(j,i)=gradx(j,i,icg)
10888           enddo
10889         enddo
10890         do i=1,4*nres
10891           glocbuf(i)=gloc(i,icg)
10892         enddo
10893 !#define DEBUG
10894 #ifdef DEBUG
10895       write (iout,*) "gloc_sc before reduce"
10896       do i=1,nres
10897        do j=1,1
10898         write (iout,*) i,j,gloc_sc(j,i,icg)
10899        enddo
10900       enddo
10901 #endif
10902 !#undef DEBUG
10903         do i=1,nres
10904          do j=1,3
10905           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10906          enddo
10907         enddo
10908         time00=MPI_Wtime()
10909         call MPI_Barrier(FG_COMM,IERR)
10910         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10911         time00=MPI_Wtime()
10912         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10913           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10914         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10915           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10916         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10917           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10918         time_reduce=time_reduce+MPI_Wtime()-time00
10919         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10920           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10921         time_reduce=time_reduce+MPI_Wtime()-time00
10922 !#define DEBUG
10923 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10924 #ifdef DEBUG
10925       write (iout,*) "gloc_sc after reduce"
10926       do i=1,nres
10927        do j=1,1
10928         write (iout,*) i,j,gloc_sc(j,i,icg)
10929        enddo
10930       enddo
10931 #endif
10932 !#undef DEBUG
10933 #ifdef DEBUG
10934       write (iout,*) "gloc after reduce"
10935       do i=1,4*nres
10936         write (iout,*) i,gloc(i,icg)
10937       enddo
10938 #endif
10939       endif
10940 #endif
10941       if (gnorm_check) then
10942 !
10943 ! Compute the maximum elements of the gradient
10944 !
10945       gvdwc_max=0.0d0
10946       gvdwc_scp_max=0.0d0
10947       gelc_max=0.0d0
10948       gvdwpp_max=0.0d0
10949       gradb_max=0.0d0
10950       ghpbc_max=0.0d0
10951       gradcorr_max=0.0d0
10952       gel_loc_max=0.0d0
10953       gcorr3_turn_max=0.0d0
10954       gcorr4_turn_max=0.0d0
10955       gradcorr5_max=0.0d0
10956       gradcorr6_max=0.0d0
10957       gcorr6_turn_max=0.0d0
10958       gsccorc_max=0.0d0
10959       gscloc_max=0.0d0
10960       gvdwx_max=0.0d0
10961       gradx_scp_max=0.0d0
10962       ghpbx_max=0.0d0
10963       gradxorr_max=0.0d0
10964       gsccorx_max=0.0d0
10965       gsclocx_max=0.0d0
10966       do i=1,nct
10967         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10968         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10969         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10970         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10971          gvdwc_scp_max=gvdwc_scp_norm
10972         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10973         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10974         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10975         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10976         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10977         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10978         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10979         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10980         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10981         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10982         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10983         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10984         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10985           gcorr3_turn(1,i)))
10986         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10987           gcorr3_turn_max=gcorr3_turn_norm
10988         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10989           gcorr4_turn(1,i)))
10990         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10991           gcorr4_turn_max=gcorr4_turn_norm
10992         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10993         if (gradcorr5_norm.gt.gradcorr5_max) &
10994           gradcorr5_max=gradcorr5_norm
10995         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10996         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10997         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10998           gcorr6_turn(1,i)))
10999         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11000           gcorr6_turn_max=gcorr6_turn_norm
11001         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11002         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11003         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11004         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11005         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11006         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11007         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11008         if (gradx_scp_norm.gt.gradx_scp_max) &
11009           gradx_scp_max=gradx_scp_norm
11010         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11011         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11012         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11013         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11014         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11015         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11016         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11017         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11018       enddo
11019       if (gradout) then
11020 #ifdef AIX
11021         open(istat,file=statname,position="append")
11022 #else
11023         open(istat,file=statname,access="append")
11024 #endif
11025         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11026            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11027            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11028            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11029            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11030            gsccorx_max,gsclocx_max
11031         close(istat)
11032         if (gvdwc_max.gt.1.0d4) then
11033           write (iout,*) "gvdwc gvdwx gradb gradbx"
11034           do i=nnt,nct
11035             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11036               gradb(j,i),gradbx(j,i),j=1,3)
11037           enddo
11038           call pdbout(0.0d0,'cipiszcze',iout)
11039           call flush(iout)
11040         endif
11041       endif
11042       endif
11043 !el#define DEBUG
11044 #ifdef DEBUG
11045       write (iout,*) "gradc gradx gloc"
11046       do i=1,nres
11047         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11048          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11049       enddo
11050 #endif
11051 !el#undef DEBUG
11052 #ifdef TIMING
11053       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11054 #endif
11055       return
11056       end subroutine sum_gradient
11057 !-----------------------------------------------------------------------------
11058       subroutine sc_grad
11059 !      implicit real*8 (a-h,o-z)
11060       use calc_data
11061 !      include 'DIMENSIONS'
11062 !      include 'COMMON.CHAIN'
11063 !      include 'COMMON.DERIV'
11064 !      include 'COMMON.CALC'
11065 !      include 'COMMON.IOUNITS'
11066       real(kind=8), dimension(3) :: dcosom1,dcosom2
11067 !      print *,"wchodze"
11068       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
11069       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
11070       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11071            -2.0D0*alf12*eps3der+sigder*sigsq_om12
11072 ! diagnostics only
11073 !      eom1=0.0d0
11074 !      eom2=0.0d0
11075 !      eom12=evdwij*eps1_om12
11076 ! end diagnostics
11077 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11078 !       " sigder",sigder
11079 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11080 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11081 !C      print *,sss_ele_cut,'in sc_grad'
11082       do k=1,3
11083         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11084         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11085       enddo
11086       do k=1,3
11087         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11088 !C      print *,'gg',k,gg(k)
11089        enddo
11090 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11091 !      write (iout,*) "gg",(gg(k),k=1,3)
11092       do k=1,3
11093         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11094                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11095                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11096                   *sss_ele_cut
11097
11098         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11099                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11100                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11101                   *sss_ele_cut
11102
11103 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11104 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11105 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11106 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11107       enddo
11108 !
11109 ! Calculate the components of the gradient in DC and X
11110 !
11111 !grad      do k=i,j-1
11112 !grad        do l=1,3
11113 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11114 !grad        enddo
11115 !grad      enddo
11116       do l=1,3
11117         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11118         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11119       enddo
11120       return
11121       end subroutine sc_grad
11122 #ifdef CRYST_THETA
11123 !-----------------------------------------------------------------------------
11124       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11125
11126       use comm_calcthet
11127 !      implicit real*8 (a-h,o-z)
11128 !      include 'DIMENSIONS'
11129 !      include 'COMMON.LOCAL'
11130 !      include 'COMMON.IOUNITS'
11131 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11132 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11133 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11134       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11135       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11136 !el      integer :: it
11137 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11138 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11139 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11140 !el local variables
11141
11142       delthec=thetai-thet_pred_mean
11143       delthe0=thetai-theta0i
11144 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11145       t3 = thetai-thet_pred_mean
11146       t6 = t3**2
11147       t9 = term1
11148       t12 = t3*sigcsq
11149       t14 = t12+t6*sigsqtc
11150       t16 = 1.0d0
11151       t21 = thetai-theta0i
11152       t23 = t21**2
11153       t26 = term2
11154       t27 = t21*t26
11155       t32 = termexp
11156       t40 = t32**2
11157       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11158        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11159        *(-t12*t9-ak*sig0inv*t27)
11160       return
11161       end subroutine mixder
11162 #endif
11163 !-----------------------------------------------------------------------------
11164 ! cartder.F
11165 !-----------------------------------------------------------------------------
11166       subroutine cartder
11167 !-----------------------------------------------------------------------------
11168 ! This subroutine calculates the derivatives of the consecutive virtual
11169 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11170 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11171 ! in the angles alpha and omega, describing the location of a side chain
11172 ! in its local coordinate system.
11173 !
11174 ! The derivatives are stored in the following arrays:
11175 !
11176 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11177 ! The structure is as follows:
11178 !
11179 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11180 ! 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)
11181 !         . . . . . . . . . . . .  . . . . . .
11182 ! 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)
11183 !                          .
11184 !                          .
11185 !                          .
11186 ! 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)
11187 !
11188 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11189 ! The structure is same as above.
11190 !
11191 ! DCDS - the derivatives of the side chain vectors in the local spherical
11192 ! andgles alph and omega:
11193 !
11194 ! 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)
11195 ! 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)
11196 !                          .
11197 !                          .
11198 !                          .
11199 ! 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)
11200 !
11201 ! Version of March '95, based on an early version of November '91.
11202 !
11203 !**********************************************************************
11204 !      implicit real*8 (a-h,o-z)
11205 !      include 'DIMENSIONS'
11206 !      include 'COMMON.VAR'
11207 !      include 'COMMON.CHAIN'
11208 !      include 'COMMON.DERIV'
11209 !      include 'COMMON.GEO'
11210 !      include 'COMMON.LOCAL'
11211 !      include 'COMMON.INTERACT'
11212       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11213       real(kind=8),dimension(3,3) :: dp,temp
11214 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11215       real(kind=8),dimension(3) :: xx,xx1
11216 !el local variables
11217       integer :: i,k,l,j,m,ind,ind1,jjj
11218       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11219                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11220                  sint2,xp,yp,xxp,yyp,zzp,dj
11221
11222 !      common /przechowalnia/ fromto
11223       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11224 ! get the position of the jth ijth fragment of the chain coordinate system
11225 ! in the fromto array.
11226 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11227 !
11228 !      maxdim=(nres-1)*(nres-2)/2
11229 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11230 ! calculate the derivatives of transformation matrix elements in theta
11231 !
11232
11233 !el      call flush(iout) !el
11234       do i=1,nres-2
11235         rdt(1,1,i)=-rt(1,2,i)
11236         rdt(1,2,i)= rt(1,1,i)
11237         rdt(1,3,i)= 0.0d0
11238         rdt(2,1,i)=-rt(2,2,i)
11239         rdt(2,2,i)= rt(2,1,i)
11240         rdt(2,3,i)= 0.0d0
11241         rdt(3,1,i)=-rt(3,2,i)
11242         rdt(3,2,i)= rt(3,1,i)
11243         rdt(3,3,i)= 0.0d0
11244       enddo
11245 !
11246 ! derivatives in phi
11247 !
11248       do i=2,nres-2
11249         drt(1,1,i)= 0.0d0
11250         drt(1,2,i)= 0.0d0
11251         drt(1,3,i)= 0.0d0
11252         drt(2,1,i)= rt(3,1,i)
11253         drt(2,2,i)= rt(3,2,i)
11254         drt(2,3,i)= rt(3,3,i)
11255         drt(3,1,i)=-rt(2,1,i)
11256         drt(3,2,i)=-rt(2,2,i)
11257         drt(3,3,i)=-rt(2,3,i)
11258       enddo
11259 !
11260 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11261 !
11262       do i=2,nres-2
11263         ind=indmat(i,i+1)
11264         do k=1,3
11265           do l=1,3
11266             temp(k,l)=rt(k,l,i)
11267           enddo
11268         enddo
11269         do k=1,3
11270           do l=1,3
11271             fromto(k,l,ind)=temp(k,l)
11272           enddo
11273         enddo
11274         do j=i+1,nres-2
11275           ind=indmat(i,j+1)
11276           do k=1,3
11277             do l=1,3
11278               dpkl=0.0d0
11279               do m=1,3
11280                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11281               enddo
11282               dp(k,l)=dpkl
11283               fromto(k,l,ind)=dpkl
11284             enddo
11285           enddo
11286           do k=1,3
11287             do l=1,3
11288               temp(k,l)=dp(k,l)
11289             enddo
11290           enddo
11291         enddo
11292       enddo
11293 !
11294 ! Calculate derivatives.
11295 !
11296       ind1=0
11297       do i=1,nres-2
11298       ind1=ind1+1
11299 !
11300 ! Derivatives of DC(i+1) in theta(i+2)
11301 !
11302         do j=1,3
11303           do k=1,2
11304             dpjk=0.0D0
11305             do l=1,3
11306               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11307             enddo
11308             dp(j,k)=dpjk
11309             prordt(j,k,i)=dp(j,k)
11310           enddo
11311           dp(j,3)=0.0D0
11312           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11313         enddo
11314 !
11315 ! Derivatives of SC(i+1) in theta(i+2)
11316 !
11317         xx1(1)=-0.5D0*xloc(2,i+1)
11318         xx1(2)= 0.5D0*xloc(1,i+1)
11319         do j=1,3
11320           xj=0.0D0
11321           do k=1,2
11322             xj=xj+r(j,k,i)*xx1(k)
11323           enddo
11324           xx(j)=xj
11325         enddo
11326         do j=1,3
11327           rj=0.0D0
11328           do k=1,3
11329             rj=rj+prod(j,k,i)*xx(k)
11330           enddo
11331           dxdv(j,ind1)=rj
11332         enddo
11333 !
11334 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11335 ! than the other off-diagonal derivatives.
11336 !
11337         do j=1,3
11338           dxoiij=0.0D0
11339           do k=1,3
11340             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11341           enddo
11342           dxdv(j,ind1+1)=dxoiij
11343         enddo
11344 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11345 !
11346 ! Derivatives of DC(i+1) in phi(i+2)
11347 !
11348         do j=1,3
11349           do k=1,3
11350             dpjk=0.0
11351             do l=2,3
11352               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11353             enddo
11354             dp(j,k)=dpjk
11355             prodrt(j,k,i)=dp(j,k)
11356           enddo
11357           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11358         enddo
11359 !
11360 ! Derivatives of SC(i+1) in phi(i+2)
11361 !
11362         xx(1)= 0.0D0
11363         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11364         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11365         do j=1,3
11366           rj=0.0D0
11367           do k=2,3
11368             rj=rj+prod(j,k,i)*xx(k)
11369           enddo
11370           dxdv(j+3,ind1)=-rj
11371         enddo
11372 !
11373 ! Derivatives of SC(i+1) in phi(i+3).
11374 !
11375         do j=1,3
11376           dxoiij=0.0D0
11377           do k=1,3
11378             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11379           enddo
11380           dxdv(j+3,ind1+1)=dxoiij
11381         enddo
11382 !
11383 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11384 ! theta(nres) and phi(i+3) thru phi(nres).
11385 !
11386         do j=i+1,nres-2
11387         ind1=ind1+1
11388         ind=indmat(i+1,j+1)
11389 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11390           do k=1,3
11391             do l=1,3
11392               tempkl=0.0D0
11393               do m=1,2
11394                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11395               enddo
11396               temp(k,l)=tempkl
11397             enddo
11398           enddo
11399 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11400 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11401 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11402 ! Derivatives of virtual-bond vectors in theta
11403           do k=1,3
11404             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11405           enddo
11406 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11407 ! Derivatives of SC vectors in theta
11408           do k=1,3
11409             dxoijk=0.0D0
11410             do l=1,3
11411               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11412             enddo
11413             dxdv(k,ind1+1)=dxoijk
11414           enddo
11415 !
11416 !--- Calculate the derivatives in phi
11417 !
11418           do k=1,3
11419             do l=1,3
11420               tempkl=0.0D0
11421               do m=1,3
11422                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11423               enddo
11424               temp(k,l)=tempkl
11425             enddo
11426           enddo
11427           do k=1,3
11428             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11429         enddo
11430           do k=1,3
11431             dxoijk=0.0D0
11432             do l=1,3
11433               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11434             enddo
11435             dxdv(k+3,ind1+1)=dxoijk
11436           enddo
11437         enddo
11438       enddo
11439 !
11440 ! Derivatives in alpha and omega:
11441 !
11442       do i=2,nres-1
11443 !       dsci=dsc(itype(i,1))
11444         dsci=vbld(i+nres)
11445 #ifdef OSF
11446         alphi=alph(i)
11447         omegi=omeg(i)
11448         if(alphi.ne.alphi) alphi=100.0
11449         if(omegi.ne.omegi) omegi=-100.0
11450 #else
11451       alphi=alph(i)
11452       omegi=omeg(i)
11453 #endif
11454 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11455       cosalphi=dcos(alphi)
11456       sinalphi=dsin(alphi)
11457       cosomegi=dcos(omegi)
11458       sinomegi=dsin(omegi)
11459       temp(1,1)=-dsci*sinalphi
11460       temp(2,1)= dsci*cosalphi*cosomegi
11461       temp(3,1)=-dsci*cosalphi*sinomegi
11462       temp(1,2)=0.0D0
11463       temp(2,2)=-dsci*sinalphi*sinomegi
11464       temp(3,2)=-dsci*sinalphi*cosomegi
11465       theta2=pi-0.5D0*theta(i+1)
11466       cost2=dcos(theta2)
11467       sint2=dsin(theta2)
11468       jjj=0
11469 !d      print *,((temp(l,k),l=1,3),k=1,2)
11470         do j=1,2
11471         xp=temp(1,j)
11472         yp=temp(2,j)
11473         xxp= xp*cost2+yp*sint2
11474         yyp=-xp*sint2+yp*cost2
11475         zzp=temp(3,j)
11476         xx(1)=xxp
11477         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11478         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11479         do k=1,3
11480           dj=0.0D0
11481           do l=1,3
11482             dj=dj+prod(k,l,i-1)*xx(l)
11483             enddo
11484           dxds(jjj+k,i)=dj
11485           enddo
11486         jjj=jjj+3
11487       enddo
11488       enddo
11489       return
11490       end subroutine cartder
11491 !-----------------------------------------------------------------------------
11492 ! checkder_p.F
11493 !-----------------------------------------------------------------------------
11494       subroutine check_cartgrad
11495 ! Check the gradient of Cartesian coordinates in internal coordinates.
11496 !      implicit real*8 (a-h,o-z)
11497 !      include 'DIMENSIONS'
11498 !      include 'COMMON.IOUNITS'
11499 !      include 'COMMON.VAR'
11500 !      include 'COMMON.CHAIN'
11501 !      include 'COMMON.GEO'
11502 !      include 'COMMON.LOCAL'
11503 !      include 'COMMON.DERIV'
11504       real(kind=8),dimension(6,nres) :: temp
11505       real(kind=8),dimension(3) :: xx,gg
11506       integer :: i,k,j,ii
11507       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11508 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11509 !
11510 ! Check the gradient of the virtual-bond and SC vectors in the internal
11511 ! coordinates.
11512 !
11513       aincr=1.0d-6
11514       aincr2=5.0d-7
11515       call cartder
11516       write (iout,'(a)') '**************** dx/dalpha'
11517       write (iout,'(a)')
11518       do i=2,nres-1
11519       alphi=alph(i)
11520       alph(i)=alph(i)+aincr
11521       do k=1,3
11522         temp(k,i)=dc(k,nres+i)
11523         enddo
11524       call chainbuild
11525       do k=1,3
11526         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11527         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11528         enddo
11529         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11530         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11531         write (iout,'(a)')
11532       alph(i)=alphi
11533       call chainbuild
11534       enddo
11535       write (iout,'(a)')
11536       write (iout,'(a)') '**************** dx/domega'
11537       write (iout,'(a)')
11538       do i=2,nres-1
11539       omegi=omeg(i)
11540       omeg(i)=omeg(i)+aincr
11541       do k=1,3
11542         temp(k,i)=dc(k,nres+i)
11543         enddo
11544       call chainbuild
11545       do k=1,3
11546           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11547           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11548                 (aincr*dabs(dxds(k+3,i))+aincr))
11549         enddo
11550         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11551             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11552         write (iout,'(a)')
11553       omeg(i)=omegi
11554       call chainbuild
11555       enddo
11556       write (iout,'(a)')
11557       write (iout,'(a)') '**************** dx/dtheta'
11558       write (iout,'(a)')
11559       do i=3,nres
11560       theti=theta(i)
11561         theta(i)=theta(i)+aincr
11562         do j=i-1,nres-1
11563           do k=1,3
11564             temp(k,j)=dc(k,nres+j)
11565           enddo
11566         enddo
11567         call chainbuild
11568         do j=i-1,nres-1
11569         ii = indmat(i-2,j)
11570 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11571         do k=1,3
11572           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11573           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11574                   (aincr*dabs(dxdv(k,ii))+aincr))
11575           enddo
11576           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11577               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11578           write(iout,'(a)')
11579         enddo
11580         write (iout,'(a)')
11581         theta(i)=theti
11582         call chainbuild
11583       enddo
11584       write (iout,'(a)') '***************** dx/dphi'
11585       write (iout,'(a)')
11586       do i=4,nres
11587         phi(i)=phi(i)+aincr
11588         do j=i-1,nres-1
11589           do k=1,3
11590             temp(k,j)=dc(k,nres+j)
11591           enddo
11592         enddo
11593         call chainbuild
11594         do j=i-1,nres-1
11595         ii = indmat(i-2,j)
11596 !         print *,'ii=',ii
11597         do k=1,3
11598           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11599             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11600                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11601           enddo
11602           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11603               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11604           write(iout,'(a)')
11605         enddo
11606         phi(i)=phi(i)-aincr
11607         call chainbuild
11608       enddo
11609       write (iout,'(a)') '****************** ddc/dtheta'
11610       do i=1,nres-2
11611         thet=theta(i+2)
11612         theta(i+2)=thet+aincr
11613         do j=i,nres
11614           do k=1,3
11615             temp(k,j)=dc(k,j)
11616           enddo
11617         enddo
11618         call chainbuild
11619         do j=i+1,nres-1
11620         ii = indmat(i,j)
11621 !         print *,'ii=',ii
11622         do k=1,3
11623           gg(k)=(dc(k,j)-temp(k,j))/aincr
11624           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11625                  (aincr*dabs(dcdv(k,ii))+aincr))
11626           enddo
11627           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11628                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11629         write (iout,'(a)')
11630         enddo
11631         do j=1,nres
11632           do k=1,3
11633             dc(k,j)=temp(k,j)
11634           enddo
11635         enddo
11636         theta(i+2)=thet
11637       enddo
11638       write (iout,'(a)') '******************* ddc/dphi'
11639       do i=1,nres-3
11640         phii=phi(i+3)
11641         phi(i+3)=phii+aincr
11642         do j=1,nres
11643           do k=1,3
11644             temp(k,j)=dc(k,j)
11645           enddo
11646         enddo
11647         call chainbuild
11648         do j=i+2,nres-1
11649         ii = indmat(i+1,j)
11650 !         print *,'ii=',ii
11651         do k=1,3
11652           gg(k)=(dc(k,j)-temp(k,j))/aincr
11653             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11654                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11655           enddo
11656           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11657                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11658         write (iout,'(a)')
11659         enddo
11660         do j=1,nres
11661           do k=1,3
11662             dc(k,j)=temp(k,j)
11663           enddo
11664         enddo
11665         phi(i+3)=phii
11666       enddo
11667       return
11668       end subroutine check_cartgrad
11669 !-----------------------------------------------------------------------------
11670       subroutine check_ecart
11671 ! Check the gradient of the energy in Cartesian coordinates.
11672 !     implicit real*8 (a-h,o-z)
11673 !     include 'DIMENSIONS'
11674 !     include 'COMMON.CHAIN'
11675 !     include 'COMMON.DERIV'
11676 !     include 'COMMON.IOUNITS'
11677 !     include 'COMMON.VAR'
11678 !     include 'COMMON.CONTACTS'
11679       use comm_srutu
11680 !el      integer :: icall
11681 !el      common /srutu/ icall
11682       real(kind=8),dimension(6) :: ggg
11683       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11684       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11685       real(kind=8),dimension(6,nres) :: grad_s
11686       real(kind=8),dimension(0:n_ene) :: energia,energia1
11687       integer :: uiparm(1)
11688       real(kind=8) :: urparm(1)
11689 !EL      external fdum
11690       integer :: nf,i,j,k
11691       real(kind=8) :: aincr,etot,etot1
11692       icg=1
11693       nf=0
11694       nfl=0
11695       call zerograd
11696       aincr=1.0D-5
11697       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11698       nf=0
11699       icall=0
11700       call geom_to_var(nvar,x)
11701       call etotal(energia)
11702       etot=energia(0)
11703 !el      call enerprint(energia)
11704       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11705       icall =1
11706       do i=1,nres
11707         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11708       enddo
11709       do i=1,nres
11710       do j=1,3
11711         grad_s(j,i)=gradc(j,i,icg)
11712         grad_s(j+3,i)=gradx(j,i,icg)
11713         enddo
11714       enddo
11715       call flush(iout)
11716       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11717       do i=1,nres
11718         do j=1,3
11719         xx(j)=c(j,i+nres)
11720         ddc(j)=dc(j,i)
11721         ddx(j)=dc(j,i+nres)
11722         enddo
11723       do j=1,3
11724         dc(j,i)=dc(j,i)+aincr
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           call etotal(energia1)
11730           etot1=energia1(0)
11731         ggg(j)=(etot1-etot)/aincr
11732         dc(j,i)=ddc(j)
11733         do k=i+1,nres
11734           c(j,k)=c(j,k)-aincr
11735           c(j,k+nres)=c(j,k+nres)-aincr
11736           enddo
11737         enddo
11738       do j=1,3
11739         c(j,i+nres)=c(j,i+nres)+aincr
11740         dc(j,i+nres)=dc(j,i+nres)+aincr
11741           call etotal(energia1)
11742           etot1=energia1(0)
11743         ggg(j+3)=(etot1-etot)/aincr
11744         c(j,i+nres)=xx(j)
11745         dc(j,i+nres)=ddx(j)
11746         enddo
11747       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11748          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11749       enddo
11750       return
11751       end subroutine check_ecart
11752 #ifdef CARGRAD
11753 !-----------------------------------------------------------------------------
11754       subroutine check_ecartint
11755 ! Check the gradient of the energy in Cartesian coordinates.
11756       use io_base, only: intout
11757 !      implicit real*8 (a-h,o-z)
11758 !      include 'DIMENSIONS'
11759 !      include 'COMMON.CONTROL'
11760 !      include 'COMMON.CHAIN'
11761 !      include 'COMMON.DERIV'
11762 !      include 'COMMON.IOUNITS'
11763 !      include 'COMMON.VAR'
11764 !      include 'COMMON.CONTACTS'
11765 !      include 'COMMON.MD'
11766 !      include 'COMMON.LOCAL'
11767 !      include 'COMMON.SPLITELE'
11768       use comm_srutu
11769 !el      integer :: icall
11770 !el      common /srutu/ icall
11771       real(kind=8),dimension(6) :: ggg,ggg1
11772       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11773       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11774       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11775       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11776       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11777       real(kind=8),dimension(0:n_ene) :: energia,energia1
11778       integer :: uiparm(1)
11779       real(kind=8) :: urparm(1)
11780 !EL      external fdum
11781       integer :: i,j,k,nf
11782       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11783                    etot21,etot22
11784       r_cut=2.0d0
11785       rlambd=0.3d0
11786       icg=1
11787       nf=0
11788       nfl=0
11789       call intout
11790 !      call intcartderiv
11791 !      call checkintcartgrad
11792       call zerograd
11793       aincr=1.0D-5
11794       write(iout,*) 'Calling CHECK_ECARTINT.'
11795       nf=0
11796       icall=0
11797       call geom_to_var(nvar,x)
11798       write (iout,*) "split_ene ",split_ene
11799       call flush(iout)
11800       if (.not.split_ene) then
11801         call etotal(energia)
11802         etot=energia(0)
11803         call cartgrad
11804         icall =1
11805         do i=1,nres
11806           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11807         enddo
11808         do j=1,3
11809           grad_s(j,0)=gcart(j,0)
11810         enddo
11811         do i=1,nres
11812           do j=1,3
11813             grad_s(j,i)=gcart(j,i)
11814             grad_s(j+3,i)=gxcart(j,i)
11815           enddo
11816         enddo
11817       else
11818 !- split gradient check
11819         call zerograd
11820         call etotal_long(energia)
11821 !el        call enerprint(energia)
11822         call cartgrad
11823         icall =1
11824         do i=1,nres
11825           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11826           (gxcart(j,i),j=1,3)
11827         enddo
11828         do j=1,3
11829           grad_s(j,0)=gcart(j,0)
11830         enddo
11831         do i=1,nres
11832           do j=1,3
11833             grad_s(j,i)=gcart(j,i)
11834             grad_s(j+3,i)=gxcart(j,i)
11835           enddo
11836         enddo
11837         call zerograd
11838         call etotal_short(energia)
11839         call enerprint(energia)
11840         call cartgrad
11841         icall =1
11842         do i=1,nres
11843           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11844           (gxcart(j,i),j=1,3)
11845         enddo
11846         do j=1,3
11847           grad_s1(j,0)=gcart(j,0)
11848         enddo
11849         do i=1,nres
11850           do j=1,3
11851             grad_s1(j,i)=gcart(j,i)
11852             grad_s1(j+3,i)=gxcart(j,i)
11853           enddo
11854         enddo
11855       endif
11856       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11857 !      do i=1,nres
11858       do i=nnt,nct
11859         do j=1,3
11860           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11861           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11862         ddc(j)=c(j,i)
11863         ddx(j)=c(j,i+nres)
11864           dcnorm_safe1(j)=dc_norm(j,i-1)
11865           dcnorm_safe2(j)=dc_norm(j,i)
11866           dxnorm_safe(j)=dc_norm(j,i+nres)
11867         enddo
11868       do j=1,3
11869         c(j,i)=ddc(j)+aincr
11870           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11871           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11872           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11873           dc(j,i)=c(j,i+1)-c(j,i)
11874           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11875           call int_from_cart1(.false.)
11876           if (.not.split_ene) then
11877             call etotal(energia1)
11878             etot1=energia1(0)
11879             write (iout,*) "ij",i,j," etot1",etot1
11880           else
11881 !- split gradient
11882             call etotal_long(energia1)
11883             etot11=energia1(0)
11884             call etotal_short(energia1)
11885             etot12=energia1(0)
11886           endif
11887 !- end split gradient
11888 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11889         c(j,i)=ddc(j)-aincr
11890           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11891           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-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             etot2=energia1(0)
11899             write (iout,*) "ij",i,j," etot2",etot2
11900           ggg(j)=(etot1-etot2)/(2*aincr)
11901           else
11902 !- split gradient
11903             call etotal_long(energia1)
11904             etot21=energia1(0)
11905           ggg(j)=(etot11-etot21)/(2*aincr)
11906             call etotal_short(energia1)
11907             etot22=energia1(0)
11908           ggg1(j)=(etot12-etot22)/(2*aincr)
11909 !- end split gradient
11910 !            write (iout,*) "etot21",etot21," etot22",etot22
11911           endif
11912 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11913         c(j,i)=ddc(j)
11914           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11915           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11916           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11917           dc(j,i)=c(j,i+1)-c(j,i)
11918           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11919           dc_norm(j,i-1)=dcnorm_safe1(j)
11920           dc_norm(j,i)=dcnorm_safe2(j)
11921           dc_norm(j,i+nres)=dxnorm_safe(j)
11922         enddo
11923       do j=1,3
11924         c(j,i+nres)=ddx(j)+aincr
11925           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11926           call int_from_cart1(.false.)
11927           if (.not.split_ene) then
11928             call etotal(energia1)
11929             etot1=energia1(0)
11930           else
11931 !- split gradient
11932             call etotal_long(energia1)
11933             etot11=energia1(0)
11934             call etotal_short(energia1)
11935             etot12=energia1(0)
11936           endif
11937 !- end split gradient
11938         c(j,i+nres)=ddx(j)-aincr
11939           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11940           call int_from_cart1(.false.)
11941           if (.not.split_ene) then
11942             call etotal(energia1)
11943             etot2=energia1(0)
11944           ggg(j+3)=(etot1-etot2)/(2*aincr)
11945           else
11946 !- split gradient
11947             call etotal_long(energia1)
11948             etot21=energia1(0)
11949           ggg(j+3)=(etot11-etot21)/(2*aincr)
11950             call etotal_short(energia1)
11951             etot22=energia1(0)
11952           ggg1(j+3)=(etot12-etot22)/(2*aincr)
11953 !- end split gradient
11954           endif
11955 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11956         c(j,i+nres)=ddx(j)
11957           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11958           dc_norm(j,i+nres)=dxnorm_safe(j)
11959           call int_from_cart1(.false.)
11960         enddo
11961       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11962          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11963         if (split_ene) then
11964           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11965          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11966          k=1,6)
11967          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11968          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11969          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11970         endif
11971       enddo
11972       return
11973       end subroutine check_ecartint
11974 #else
11975 !-----------------------------------------------------------------------------
11976       subroutine check_ecartint
11977 ! Check the gradient of the energy in Cartesian coordinates.
11978       use io_base, only: intout
11979 !      implicit real*8 (a-h,o-z)
11980 !      include 'DIMENSIONS'
11981 !      include 'COMMON.CONTROL'
11982 !      include 'COMMON.CHAIN'
11983 !      include 'COMMON.DERIV'
11984 !      include 'COMMON.IOUNITS'
11985 !      include 'COMMON.VAR'
11986 !      include 'COMMON.CONTACTS'
11987 !      include 'COMMON.MD'
11988 !      include 'COMMON.LOCAL'
11989 !      include 'COMMON.SPLITELE'
11990       use comm_srutu
11991 !el      integer :: icall
11992 !el      common /srutu/ icall
11993       real(kind=8),dimension(6) :: ggg,ggg1
11994       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11995       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11996       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11997       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11998       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11999       real(kind=8),dimension(0:n_ene) :: energia,energia1
12000       integer :: uiparm(1)
12001       real(kind=8) :: urparm(1)
12002 !EL      external fdum
12003       integer :: i,j,k,nf
12004       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12005                    etot21,etot22
12006       r_cut=2.0d0
12007       rlambd=0.3d0
12008       icg=1
12009       nf=0
12010       nfl=0
12011       call intout
12012 !      call intcartderiv
12013 !      call checkintcartgrad
12014       call zerograd
12015       aincr=2.0D-5
12016       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12017       nf=0
12018       icall=0
12019       call geom_to_var(nvar,x)
12020       if (.not.split_ene) then
12021         call etotal(energia)
12022         etot=energia(0)
12023 !el        call enerprint(energia)
12024         call cartgrad
12025         icall =1
12026         do i=1,nres
12027           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12028         enddo
12029         do j=1,3
12030           grad_s(j,0)=gcart(j,0)
12031         enddo
12032         do i=1,nres
12033           do j=1,3
12034             grad_s(j,i)=gcart(j,i)
12035 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12036             grad_s(j+3,i)=gxcart(j,i)
12037           enddo
12038         enddo
12039       else
12040 !- split gradient check
12041         call zerograd
12042         call etotal_long(energia)
12043 !el        call enerprint(energia)
12044         call cartgrad
12045         icall =1
12046         do i=1,nres
12047           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12048           (gxcart(j,i),j=1,3)
12049         enddo
12050         do j=1,3
12051           grad_s(j,0)=gcart(j,0)
12052         enddo
12053         do i=1,nres
12054           do j=1,3
12055             grad_s(j,i)=gcart(j,i)
12056             grad_s(j+3,i)=gxcart(j,i)
12057           enddo
12058         enddo
12059         call zerograd
12060         call etotal_short(energia)
12061 !el        call enerprint(energia)
12062         call cartgrad
12063         icall =1
12064         do i=1,nres
12065           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12066           (gxcart(j,i),j=1,3)
12067         enddo
12068         do j=1,3
12069           grad_s1(j,0)=gcart(j,0)
12070         enddo
12071         do i=1,nres
12072           do j=1,3
12073             grad_s1(j,i)=gcart(j,i)
12074             grad_s1(j+3,i)=gxcart(j,i)
12075           enddo
12076         enddo
12077       endif
12078       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12079       do i=0,nres
12080         do j=1,3
12081         xx(j)=c(j,i+nres)
12082         ddc(j)=dc(j,i)
12083         ddx(j)=dc(j,i+nres)
12084           do k=1,3
12085             dcnorm_safe(k)=dc_norm(k,i)
12086             dxnorm_safe(k)=dc_norm(k,i+nres)
12087           enddo
12088         enddo
12089       do j=1,3
12090         dc(j,i)=ddc(j)+aincr
12091           call chainbuild_cart
12092 #ifdef MPI
12093 ! Broadcast the order to compute internal coordinates to the slaves.
12094 !          if (nfgtasks.gt.1)
12095 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12096 #endif
12097 !          call int_from_cart1(.false.)
12098           if (.not.split_ene) then
12099             call etotal(energia1)
12100             etot1=energia1(0)
12101 !            call enerprint(energia1)
12102           else
12103 !- split gradient
12104             call etotal_long(energia1)
12105             etot11=energia1(0)
12106             call etotal_short(energia1)
12107             etot12=energia1(0)
12108 !            write (iout,*) "etot11",etot11," etot12",etot12
12109           endif
12110 !- end split gradient
12111 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12112         dc(j,i)=ddc(j)-aincr
12113           call chainbuild_cart
12114 !          call int_from_cart1(.false.)
12115           if (.not.split_ene) then
12116             call etotal(energia1)
12117             etot2=energia1(0)
12118           ggg(j)=(etot1-etot2)/(2*aincr)
12119           else
12120 !- split gradient
12121             call etotal_long(energia1)
12122             etot21=energia1(0)
12123           ggg(j)=(etot11-etot21)/(2*aincr)
12124             call etotal_short(energia1)
12125             etot22=energia1(0)
12126           ggg1(j)=(etot12-etot22)/(2*aincr)
12127 !- end split gradient
12128 !            write (iout,*) "etot21",etot21," etot22",etot22
12129           endif
12130 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12131         dc(j,i)=ddc(j)
12132           call chainbuild_cart
12133         enddo
12134       do j=1,3
12135         dc(j,i+nres)=ddx(j)+aincr
12136           call chainbuild_cart
12137 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12138 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12139 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12140 !          write (iout,*) "dxnormnorm",dsqrt(
12141 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12142 !          write (iout,*) "dxnormnormsafe",dsqrt(
12143 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12144 !          write (iout,*)
12145           if (.not.split_ene) then
12146             call etotal(energia1)
12147             etot1=energia1(0)
12148           else
12149 !- split gradient
12150             call etotal_long(energia1)
12151             etot11=energia1(0)
12152             call etotal_short(energia1)
12153             etot12=energia1(0)
12154           endif
12155 !- end split gradient
12156 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12157         dc(j,i+nres)=ddx(j)-aincr
12158           call chainbuild_cart
12159 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12160 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12161 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12162 !          write (iout,*)
12163 !          write (iout,*) "dxnormnorm",dsqrt(
12164 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12165 !          write (iout,*) "dxnormnormsafe",dsqrt(
12166 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12167           if (.not.split_ene) then
12168             call etotal(energia1)
12169             etot2=energia1(0)
12170           ggg(j+3)=(etot1-etot2)/(2*aincr)
12171           else
12172 !- split gradient
12173             call etotal_long(energia1)
12174             etot21=energia1(0)
12175           ggg(j+3)=(etot11-etot21)/(2*aincr)
12176             call etotal_short(energia1)
12177             etot22=energia1(0)
12178           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12179 !- end split gradient
12180           endif
12181 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12182         dc(j,i+nres)=ddx(j)
12183           call chainbuild_cart
12184         enddo
12185       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12186          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12187         if (split_ene) then
12188           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12189          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12190          k=1,6)
12191          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12192          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12193          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12194         endif
12195       enddo
12196       return
12197       end subroutine check_ecartint
12198 #endif
12199 !-----------------------------------------------------------------------------
12200       subroutine check_eint
12201 ! Check the gradient of energy in internal coordinates.
12202 !      implicit real*8 (a-h,o-z)
12203 !      include 'DIMENSIONS'
12204 !      include 'COMMON.CHAIN'
12205 !      include 'COMMON.DERIV'
12206 !      include 'COMMON.IOUNITS'
12207 !      include 'COMMON.VAR'
12208 !      include 'COMMON.GEO'
12209       use comm_srutu
12210 !el      integer :: icall
12211 !el      common /srutu/ icall
12212       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12213       integer :: uiparm(1)
12214       real(kind=8) :: urparm(1)
12215       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12216       character(len=6) :: key
12217 !EL      external fdum
12218       integer :: i,ii,nf
12219       real(kind=8) :: xi,aincr,etot,etot1,etot2
12220       call zerograd
12221       aincr=1.0D-7
12222       print '(a)','Calling CHECK_INT.'
12223       nf=0
12224       nfl=0
12225       icg=1
12226       call geom_to_var(nvar,x)
12227       call var_to_geom(nvar,x)
12228       call chainbuild
12229       icall=1
12230 !      print *,'ICG=',ICG
12231       call etotal(energia)
12232       etot = energia(0)
12233 !el      call enerprint(energia)
12234 !      print *,'ICG=',ICG
12235 #ifdef MPL
12236       if (MyID.ne.BossID) then
12237         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12238         nf=x(nvar+1)
12239         nfl=x(nvar+2)
12240         icg=x(nvar+3)
12241       endif
12242 #endif
12243       nf=1
12244       nfl=3
12245 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12246       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12247 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12248       icall=1
12249       do i=1,nvar
12250         xi=x(i)
12251         x(i)=xi-0.5D0*aincr
12252         call var_to_geom(nvar,x)
12253         call chainbuild
12254         call etotal(energia1)
12255         etot1=energia1(0)
12256         x(i)=xi+0.5D0*aincr
12257         call var_to_geom(nvar,x)
12258         call chainbuild
12259         call etotal(energia2)
12260         etot2=energia2(0)
12261         gg(i)=(etot2-etot1)/aincr
12262         write (iout,*) i,etot1,etot2
12263         x(i)=xi
12264       enddo
12265       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12266           '     RelDiff*100% '
12267       do i=1,nvar
12268         if (i.le.nphi) then
12269           ii=i
12270           key = ' phi'
12271         else if (i.le.nphi+ntheta) then
12272           ii=i-nphi
12273           key=' theta'
12274         else if (i.le.nphi+ntheta+nside) then
12275            ii=i-(nphi+ntheta)
12276            key=' alpha'
12277         else
12278            ii=i-(nphi+ntheta+nside)
12279            key=' omega'
12280         endif
12281         write (iout,'(i3,a,i3,3(1pd16.6))') &
12282        i,key,ii,gg(i),gana(i),&
12283        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12284       enddo
12285       return
12286       end subroutine check_eint
12287 !-----------------------------------------------------------------------------
12288 ! econstr_local.F
12289 !-----------------------------------------------------------------------------
12290       subroutine Econstr_back
12291 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12292 !      implicit real*8 (a-h,o-z)
12293 !      include 'DIMENSIONS'
12294 !      include 'COMMON.CONTROL'
12295 !      include 'COMMON.VAR'
12296 !      include 'COMMON.MD'
12297       use MD_data
12298 !#ifndef LANG0
12299 !      include 'COMMON.LANGEVIN'
12300 !#else
12301 !      include 'COMMON.LANGEVIN.lang0'
12302 !#endif
12303 !      include 'COMMON.CHAIN'
12304 !      include 'COMMON.DERIV'
12305 !      include 'COMMON.GEO'
12306 !      include 'COMMON.LOCAL'
12307 !      include 'COMMON.INTERACT'
12308 !      include 'COMMON.IOUNITS'
12309 !      include 'COMMON.NAMES'
12310 !      include 'COMMON.TIME1'
12311       integer :: i,j,ii,k
12312       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12313
12314       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12315       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12316       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12317
12318       Uconst_back=0.0d0
12319       do i=1,nres
12320         dutheta(i)=0.0d0
12321         dugamma(i)=0.0d0
12322         do j=1,3
12323           duscdiff(j,i)=0.0d0
12324           duscdiffx(j,i)=0.0d0
12325         enddo
12326       enddo
12327       do i=1,nfrag_back
12328         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12329 !
12330 ! Deviations from theta angles
12331 !
12332         utheta_i=0.0d0
12333         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12334           dtheta_i=theta(j)-thetaref(j)
12335           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12336           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12337         enddo
12338         utheta(i)=utheta_i/(ii-1)
12339 !
12340 ! Deviations from gamma angles
12341 !
12342         ugamma_i=0.0d0
12343         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12344           dgamma_i=pinorm(phi(j)-phiref(j))
12345 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12346           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12347           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12348 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12349         enddo
12350         ugamma(i)=ugamma_i/(ii-2)
12351 !
12352 ! Deviations from local SC geometry
12353 !
12354         uscdiff(i)=0.0d0
12355         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12356           dxx=xxtab(j)-xxref(j)
12357           dyy=yytab(j)-yyref(j)
12358           dzz=zztab(j)-zzref(j)
12359           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12360           do k=1,3
12361             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12362              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12363              (ii-1)
12364             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12365              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12366              (ii-1)
12367             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12368            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12369             /(ii-1)
12370           enddo
12371 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12372 !     &      xxref(j),yyref(j),zzref(j)
12373         enddo
12374         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12375 !        write (iout,*) i," uscdiff",uscdiff(i)
12376 !
12377 ! Put together deviations from local geometry
12378 !
12379         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12380           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12381 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12382 !     &   " uconst_back",uconst_back
12383         utheta(i)=dsqrt(utheta(i))
12384         ugamma(i)=dsqrt(ugamma(i))
12385         uscdiff(i)=dsqrt(uscdiff(i))
12386       enddo
12387       return
12388       end subroutine Econstr_back
12389 !-----------------------------------------------------------------------------
12390 ! energy_p_new-sep_barrier.F
12391 !-----------------------------------------------------------------------------
12392       real(kind=8) function sscale(r)
12393 !      include "COMMON.SPLITELE"
12394       real(kind=8) :: r,gamm
12395       if(r.lt.r_cut-rlamb) then
12396         sscale=1.0d0
12397       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12398         gamm=(r-(r_cut-rlamb))/rlamb
12399         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12400       else
12401         sscale=0d0
12402       endif
12403       return
12404       end function sscale
12405       real(kind=8) function sscale_grad(r)
12406 !      include "COMMON.SPLITELE"
12407       real(kind=8) :: r,gamm
12408       if(r.lt.r_cut-rlamb) then
12409         sscale_grad=0.0d0
12410       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12411         gamm=(r-(r_cut-rlamb))/rlamb
12412         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12413       else
12414         sscale_grad=0d0
12415       endif
12416       return
12417       end function sscale_grad
12418
12419 !!!!!!!!!! PBCSCALE
12420       real(kind=8) function sscale_ele(r)
12421 !      include "COMMON.SPLITELE"
12422       real(kind=8) :: r,gamm
12423       if(r.lt.r_cut_ele-rlamb_ele) then
12424         sscale_ele=1.0d0
12425       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12426         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12427         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12428       else
12429         sscale_ele=0d0
12430       endif
12431       return
12432       end function sscale_ele
12433
12434       real(kind=8)  function sscagrad_ele(r)
12435       real(kind=8) :: r,gamm
12436 !      include "COMMON.SPLITELE"
12437       if(r.lt.r_cut_ele-rlamb_ele) then
12438         sscagrad_ele=0.0d0
12439       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12440         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12441         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12442       else
12443         sscagrad_ele=0.0d0
12444       endif
12445       return
12446       end function sscagrad_ele
12447       real(kind=8) function sscalelip(r)
12448       real(kind=8) r,gamm
12449         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12450       return
12451       end function sscalelip
12452 !C-----------------------------------------------------------------------
12453       real(kind=8) function sscagradlip(r)
12454       real(kind=8) r,gamm
12455         sscagradlip=r*(6.0d0*r-6.0d0)
12456       return
12457       end function sscagradlip
12458
12459 !!!!!!!!!!!!!!!
12460 !-----------------------------------------------------------------------------
12461       subroutine elj_long(evdw)
12462 !
12463 ! This subroutine calculates the interaction energy of nonbonded side chains
12464 ! assuming the LJ potential of interaction.
12465 !
12466 !      implicit real*8 (a-h,o-z)
12467 !      include 'DIMENSIONS'
12468 !      include 'COMMON.GEO'
12469 !      include 'COMMON.VAR'
12470 !      include 'COMMON.LOCAL'
12471 !      include 'COMMON.CHAIN'
12472 !      include 'COMMON.DERIV'
12473 !      include 'COMMON.INTERACT'
12474 !      include 'COMMON.TORSION'
12475 !      include 'COMMON.SBRIDGE'
12476 !      include 'COMMON.NAMES'
12477 !      include 'COMMON.IOUNITS'
12478 !      include 'COMMON.CONTACTS'
12479       real(kind=8),parameter :: accur=1.0d-10
12480       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12481 !el local variables
12482       integer :: i,iint,j,k,itypi,itypi1,itypj
12483       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12484       real(kind=8) :: e1,e2,evdwij,evdw
12485 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12486       evdw=0.0D0
12487       do i=iatsc_s,iatsc_e
12488         itypi=itype(i,1)
12489         if (itypi.eq.ntyp1) cycle
12490         itypi1=itype(i+1,1)
12491         xi=c(1,nres+i)
12492         yi=c(2,nres+i)
12493         zi=c(3,nres+i)
12494 !
12495 ! Calculate SC interaction energy.
12496 !
12497         do iint=1,nint_gr(i)
12498 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12499 !d   &                  'iend=',iend(i,iint)
12500           do j=istart(i,iint),iend(i,iint)
12501             itypj=itype(j,1)
12502             if (itypj.eq.ntyp1) cycle
12503             xj=c(1,nres+j)-xi
12504             yj=c(2,nres+j)-yi
12505             zj=c(3,nres+j)-zi
12506             rij=xj*xj+yj*yj+zj*zj
12507             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12508             if (sss.lt.1.0d0) then
12509               rrij=1.0D0/rij
12510               eps0ij=eps(itypi,itypj)
12511               fac=rrij**expon2
12512               e1=fac*fac*aa_aq(itypi,itypj)
12513               e2=fac*bb_aq(itypi,itypj)
12514               evdwij=e1+e2
12515               evdw=evdw+(1.0d0-sss)*evdwij
12516 !
12517 ! Calculate the components of the gradient in DC and X
12518 !
12519               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12520               gg(1)=xj*fac
12521               gg(2)=yj*fac
12522               gg(3)=zj*fac
12523               do k=1,3
12524                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12525                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12526                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12527                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12528               enddo
12529             endif
12530           enddo      ! j
12531         enddo        ! iint
12532       enddo          ! i
12533       do i=1,nct
12534         do j=1,3
12535           gvdwc(j,i)=expon*gvdwc(j,i)
12536           gvdwx(j,i)=expon*gvdwx(j,i)
12537         enddo
12538       enddo
12539 !******************************************************************************
12540 !
12541 !                              N O T E !!!
12542 !
12543 ! To save time, the factor of EXPON has been extracted from ALL components
12544 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12545 ! use!
12546 !
12547 !******************************************************************************
12548       return
12549       end subroutine elj_long
12550 !-----------------------------------------------------------------------------
12551       subroutine elj_short(evdw)
12552 !
12553 ! This subroutine calculates the interaction energy of nonbonded side chains
12554 ! assuming the LJ potential of interaction.
12555 !
12556 !      implicit real*8 (a-h,o-z)
12557 !      include 'DIMENSIONS'
12558 !      include 'COMMON.GEO'
12559 !      include 'COMMON.VAR'
12560 !      include 'COMMON.LOCAL'
12561 !      include 'COMMON.CHAIN'
12562 !      include 'COMMON.DERIV'
12563 !      include 'COMMON.INTERACT'
12564 !      include 'COMMON.TORSION'
12565 !      include 'COMMON.SBRIDGE'
12566 !      include 'COMMON.NAMES'
12567 !      include 'COMMON.IOUNITS'
12568 !      include 'COMMON.CONTACTS'
12569       real(kind=8),parameter :: accur=1.0d-10
12570       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12571 !el local variables
12572       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12573       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12574       real(kind=8) :: e1,e2,evdwij,evdw
12575 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12576       evdw=0.0D0
12577       do i=iatsc_s,iatsc_e
12578         itypi=itype(i,1)
12579         if (itypi.eq.ntyp1) cycle
12580         itypi1=itype(i+1,1)
12581         xi=c(1,nres+i)
12582         yi=c(2,nres+i)
12583         zi=c(3,nres+i)
12584 ! Change 12/1/95
12585         num_conti=0
12586 !
12587 ! Calculate SC interaction energy.
12588 !
12589         do iint=1,nint_gr(i)
12590 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12591 !d   &                  'iend=',iend(i,iint)
12592           do j=istart(i,iint),iend(i,iint)
12593             itypj=itype(j,1)
12594             if (itypj.eq.ntyp1) cycle
12595             xj=c(1,nres+j)-xi
12596             yj=c(2,nres+j)-yi
12597             zj=c(3,nres+j)-zi
12598 ! Change 12/1/95 to calculate four-body interactions
12599             rij=xj*xj+yj*yj+zj*zj
12600             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12601             if (sss.gt.0.0d0) then
12602               rrij=1.0D0/rij
12603               eps0ij=eps(itypi,itypj)
12604               fac=rrij**expon2
12605               e1=fac*fac*aa_aq(itypi,itypj)
12606               e2=fac*bb_aq(itypi,itypj)
12607               evdwij=e1+e2
12608               evdw=evdw+sss*evdwij
12609 !
12610 ! Calculate the components of the gradient in DC and X
12611 !
12612               fac=-rrij*(e1+evdwij)*sss
12613               gg(1)=xj*fac
12614               gg(2)=yj*fac
12615               gg(3)=zj*fac
12616               do k=1,3
12617                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12618                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12619                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12620                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12621               enddo
12622             endif
12623           enddo      ! j
12624         enddo        ! iint
12625       enddo          ! i
12626       do i=1,nct
12627         do j=1,3
12628           gvdwc(j,i)=expon*gvdwc(j,i)
12629           gvdwx(j,i)=expon*gvdwx(j,i)
12630         enddo
12631       enddo
12632 !******************************************************************************
12633 !
12634 !                              N O T E !!!
12635 !
12636 ! To save time, the factor of EXPON has been extracted from ALL components
12637 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12638 ! use!
12639 !
12640 !******************************************************************************
12641       return
12642       end subroutine elj_short
12643 !-----------------------------------------------------------------------------
12644       subroutine eljk_long(evdw)
12645 !
12646 ! This subroutine calculates the interaction energy of nonbonded side chains
12647 ! assuming the LJK potential of interaction.
12648 !
12649 !      implicit real*8 (a-h,o-z)
12650 !      include 'DIMENSIONS'
12651 !      include 'COMMON.GEO'
12652 !      include 'COMMON.VAR'
12653 !      include 'COMMON.LOCAL'
12654 !      include 'COMMON.CHAIN'
12655 !      include 'COMMON.DERIV'
12656 !      include 'COMMON.INTERACT'
12657 !      include 'COMMON.IOUNITS'
12658 !      include 'COMMON.NAMES'
12659       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12660       logical :: scheck
12661 !el local variables
12662       integer :: i,iint,j,k,itypi,itypi1,itypj
12663       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12664                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12665 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12666       evdw=0.0D0
12667       do i=iatsc_s,iatsc_e
12668         itypi=itype(i,1)
12669         if (itypi.eq.ntyp1) cycle
12670         itypi1=itype(i+1,1)
12671         xi=c(1,nres+i)
12672         yi=c(2,nres+i)
12673         zi=c(3,nres+i)
12674 !
12675 ! Calculate SC interaction energy.
12676 !
12677         do iint=1,nint_gr(i)
12678           do j=istart(i,iint),iend(i,iint)
12679             itypj=itype(j,1)
12680             if (itypj.eq.ntyp1) cycle
12681             xj=c(1,nres+j)-xi
12682             yj=c(2,nres+j)-yi
12683             zj=c(3,nres+j)-zi
12684             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12685             fac_augm=rrij**expon
12686             e_augm=augm(itypi,itypj)*fac_augm
12687             r_inv_ij=dsqrt(rrij)
12688             rij=1.0D0/r_inv_ij
12689             sss=sscale(rij/sigma(itypi,itypj))
12690             if (sss.lt.1.0d0) then
12691               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12692               fac=r_shift_inv**expon
12693               e1=fac*fac*aa_aq(itypi,itypj)
12694               e2=fac*bb_aq(itypi,itypj)
12695               evdwij=e_augm+e1+e2
12696 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12697 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12698 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12699 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12700 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12701 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12702 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12703               evdw=evdw+(1.0d0-sss)*evdwij
12704 !
12705 ! Calculate the components of the gradient in DC and X
12706 !
12707               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12708               fac=fac*(1.0d0-sss)
12709               gg(1)=xj*fac
12710               gg(2)=yj*fac
12711               gg(3)=zj*fac
12712               do k=1,3
12713                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12714                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12715                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12716                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12717               enddo
12718             endif
12719           enddo      ! j
12720         enddo        ! iint
12721       enddo          ! i
12722       do i=1,nct
12723         do j=1,3
12724           gvdwc(j,i)=expon*gvdwc(j,i)
12725           gvdwx(j,i)=expon*gvdwx(j,i)
12726         enddo
12727       enddo
12728       return
12729       end subroutine eljk_long
12730 !-----------------------------------------------------------------------------
12731       subroutine eljk_short(evdw)
12732 !
12733 ! This subroutine calculates the interaction energy of nonbonded side chains
12734 ! assuming the LJK potential of interaction.
12735 !
12736 !      implicit real*8 (a-h,o-z)
12737 !      include 'DIMENSIONS'
12738 !      include 'COMMON.GEO'
12739 !      include 'COMMON.VAR'
12740 !      include 'COMMON.LOCAL'
12741 !      include 'COMMON.CHAIN'
12742 !      include 'COMMON.DERIV'
12743 !      include 'COMMON.INTERACT'
12744 !      include 'COMMON.IOUNITS'
12745 !      include 'COMMON.NAMES'
12746       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12747       logical :: scheck
12748 !el local variables
12749       integer :: i,iint,j,k,itypi,itypi1,itypj
12750       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12751                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12752 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12753       evdw=0.0D0
12754       do i=iatsc_s,iatsc_e
12755         itypi=itype(i,1)
12756         if (itypi.eq.ntyp1) cycle
12757         itypi1=itype(i+1,1)
12758         xi=c(1,nres+i)
12759         yi=c(2,nres+i)
12760         zi=c(3,nres+i)
12761 !
12762 ! Calculate SC interaction energy.
12763 !
12764         do iint=1,nint_gr(i)
12765           do j=istart(i,iint),iend(i,iint)
12766             itypj=itype(j,1)
12767             if (itypj.eq.ntyp1) cycle
12768             xj=c(1,nres+j)-xi
12769             yj=c(2,nres+j)-yi
12770             zj=c(3,nres+j)-zi
12771             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12772             fac_augm=rrij**expon
12773             e_augm=augm(itypi,itypj)*fac_augm
12774             r_inv_ij=dsqrt(rrij)
12775             rij=1.0D0/r_inv_ij
12776             sss=sscale(rij/sigma(itypi,itypj))
12777             if (sss.gt.0.0d0) then
12778               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12779               fac=r_shift_inv**expon
12780               e1=fac*fac*aa_aq(itypi,itypj)
12781               e2=fac*bb_aq(itypi,itypj)
12782               evdwij=e_augm+e1+e2
12783 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12784 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12785 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12786 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12787 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12788 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12789 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12790               evdw=evdw+sss*evdwij
12791 !
12792 ! Calculate the components of the gradient in DC and X
12793 !
12794               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12795               fac=fac*sss
12796               gg(1)=xj*fac
12797               gg(2)=yj*fac
12798               gg(3)=zj*fac
12799               do k=1,3
12800                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12801                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12802                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12803                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12804               enddo
12805             endif
12806           enddo      ! j
12807         enddo        ! iint
12808       enddo          ! i
12809       do i=1,nct
12810         do j=1,3
12811           gvdwc(j,i)=expon*gvdwc(j,i)
12812           gvdwx(j,i)=expon*gvdwx(j,i)
12813         enddo
12814       enddo
12815       return
12816       end subroutine eljk_short
12817 !-----------------------------------------------------------------------------
12818       subroutine ebp_long(evdw)
12819 !
12820 ! This subroutine calculates the interaction energy of nonbonded side chains
12821 ! assuming the Berne-Pechukas potential of interaction.
12822 !
12823       use calc_data
12824 !      implicit real*8 (a-h,o-z)
12825 !      include 'DIMENSIONS'
12826 !      include 'COMMON.GEO'
12827 !      include 'COMMON.VAR'
12828 !      include 'COMMON.LOCAL'
12829 !      include 'COMMON.CHAIN'
12830 !      include 'COMMON.DERIV'
12831 !      include 'COMMON.NAMES'
12832 !      include 'COMMON.INTERACT'
12833 !      include 'COMMON.IOUNITS'
12834 !      include 'COMMON.CALC'
12835       use comm_srutu
12836 !el      integer :: icall
12837 !el      common /srutu/ icall
12838 !     double precision rrsave(maxdim)
12839       logical :: lprn
12840 !el local variables
12841       integer :: iint,itypi,itypi1,itypj
12842       real(kind=8) :: rrij,xi,yi,zi,fac
12843       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12844       evdw=0.0D0
12845 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12846       evdw=0.0D0
12847 !     if (icall.eq.0) then
12848 !       lprn=.true.
12849 !     else
12850         lprn=.false.
12851 !     endif
12852 !el      ind=0
12853       do i=iatsc_s,iatsc_e
12854         itypi=itype(i,1)
12855         if (itypi.eq.ntyp1) cycle
12856         itypi1=itype(i+1,1)
12857         xi=c(1,nres+i)
12858         yi=c(2,nres+i)
12859         zi=c(3,nres+i)
12860         dxi=dc_norm(1,nres+i)
12861         dyi=dc_norm(2,nres+i)
12862         dzi=dc_norm(3,nres+i)
12863 !        dsci_inv=dsc_inv(itypi)
12864         dsci_inv=vbld_inv(i+nres)
12865 !
12866 ! Calculate SC interaction energy.
12867 !
12868         do iint=1,nint_gr(i)
12869           do j=istart(i,iint),iend(i,iint)
12870 !el            ind=ind+1
12871             itypj=itype(j,1)
12872             if (itypj.eq.ntyp1) cycle
12873 !            dscj_inv=dsc_inv(itypj)
12874             dscj_inv=vbld_inv(j+nres)
12875             chi1=chi(itypi,itypj)
12876             chi2=chi(itypj,itypi)
12877             chi12=chi1*chi2
12878             chip1=chip(itypi)
12879             chip2=chip(itypj)
12880             chip12=chip1*chip2
12881             alf1=alp(itypi)
12882             alf2=alp(itypj)
12883             alf12=0.5D0*(alf1+alf2)
12884             xj=c(1,nres+j)-xi
12885             yj=c(2,nres+j)-yi
12886             zj=c(3,nres+j)-zi
12887             dxj=dc_norm(1,nres+j)
12888             dyj=dc_norm(2,nres+j)
12889             dzj=dc_norm(3,nres+j)
12890             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12891             rij=dsqrt(rrij)
12892             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12893
12894             if (sss.lt.1.0d0) then
12895
12896 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12897               call sc_angular
12898 ! Calculate whole angle-dependent part of epsilon and contributions
12899 ! to its derivatives
12900               fac=(rrij*sigsq)**expon2
12901               e1=fac*fac*aa_aq(itypi,itypj)
12902               e2=fac*bb_aq(itypi,itypj)
12903               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12904               eps2der=evdwij*eps3rt
12905               eps3der=evdwij*eps2rt
12906               evdwij=evdwij*eps2rt*eps3rt
12907               evdw=evdw+evdwij*(1.0d0-sss)
12908               if (lprn) then
12909               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12910               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12911 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12912 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12913 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12914 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12915 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12916 !d     &          evdwij
12917               endif
12918 ! Calculate gradient components.
12919               e1=e1*eps1*eps2rt**2*eps3rt**2
12920               fac=-expon*(e1+evdwij)
12921               sigder=fac/sigsq
12922               fac=rrij*fac
12923 ! Calculate radial part of the gradient
12924               gg(1)=xj*fac
12925               gg(2)=yj*fac
12926               gg(3)=zj*fac
12927 ! Calculate the angular part of the gradient and sum add the contributions
12928 ! to the appropriate components of the Cartesian gradient.
12929               call sc_grad_scale(1.0d0-sss)
12930             endif
12931           enddo      ! j
12932         enddo        ! iint
12933       enddo          ! i
12934 !     stop
12935       return
12936       end subroutine ebp_long
12937 !-----------------------------------------------------------------------------
12938       subroutine ebp_short(evdw)
12939 !
12940 ! This subroutine calculates the interaction energy of nonbonded side chains
12941 ! assuming the Berne-Pechukas potential of interaction.
12942 !
12943       use calc_data
12944 !      implicit real*8 (a-h,o-z)
12945 !      include 'DIMENSIONS'
12946 !      include 'COMMON.GEO'
12947 !      include 'COMMON.VAR'
12948 !      include 'COMMON.LOCAL'
12949 !      include 'COMMON.CHAIN'
12950 !      include 'COMMON.DERIV'
12951 !      include 'COMMON.NAMES'
12952 !      include 'COMMON.INTERACT'
12953 !      include 'COMMON.IOUNITS'
12954 !      include 'COMMON.CALC'
12955       use comm_srutu
12956 !el      integer :: icall
12957 !el      common /srutu/ icall
12958 !     double precision rrsave(maxdim)
12959       logical :: lprn
12960 !el local variables
12961       integer :: iint,itypi,itypi1,itypj
12962       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12963       real(kind=8) :: sss,e1,e2,evdw
12964       evdw=0.0D0
12965 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12966       evdw=0.0D0
12967 !     if (icall.eq.0) then
12968 !       lprn=.true.
12969 !     else
12970         lprn=.false.
12971 !     endif
12972 !el      ind=0
12973       do i=iatsc_s,iatsc_e
12974         itypi=itype(i,1)
12975         if (itypi.eq.ntyp1) cycle
12976         itypi1=itype(i+1,1)
12977         xi=c(1,nres+i)
12978         yi=c(2,nres+i)
12979         zi=c(3,nres+i)
12980         dxi=dc_norm(1,nres+i)
12981         dyi=dc_norm(2,nres+i)
12982         dzi=dc_norm(3,nres+i)
12983 !        dsci_inv=dsc_inv(itypi)
12984         dsci_inv=vbld_inv(i+nres)
12985 !
12986 ! Calculate SC interaction energy.
12987 !
12988         do iint=1,nint_gr(i)
12989           do j=istart(i,iint),iend(i,iint)
12990 !el            ind=ind+1
12991             itypj=itype(j,1)
12992             if (itypj.eq.ntyp1) cycle
12993 !            dscj_inv=dsc_inv(itypj)
12994             dscj_inv=vbld_inv(j+nres)
12995             chi1=chi(itypi,itypj)
12996             chi2=chi(itypj,itypi)
12997             chi12=chi1*chi2
12998             chip1=chip(itypi)
12999             chip2=chip(itypj)
13000             chip12=chip1*chip2
13001             alf1=alp(itypi)
13002             alf2=alp(itypj)
13003             alf12=0.5D0*(alf1+alf2)
13004             xj=c(1,nres+j)-xi
13005             yj=c(2,nres+j)-yi
13006             zj=c(3,nres+j)-zi
13007             dxj=dc_norm(1,nres+j)
13008             dyj=dc_norm(2,nres+j)
13009             dzj=dc_norm(3,nres+j)
13010             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13011             rij=dsqrt(rrij)
13012             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13013
13014             if (sss.gt.0.0d0) then
13015
13016 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13017               call sc_angular
13018 ! Calculate whole angle-dependent part of epsilon and contributions
13019 ! to its derivatives
13020               fac=(rrij*sigsq)**expon2
13021               e1=fac*fac*aa_aq(itypi,itypj)
13022               e2=fac*bb_aq(itypi,itypj)
13023               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13024               eps2der=evdwij*eps3rt
13025               eps3der=evdwij*eps2rt
13026               evdwij=evdwij*eps2rt*eps3rt
13027               evdw=evdw+evdwij*sss
13028               if (lprn) then
13029               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13030               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13031 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13032 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13033 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13034 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13035 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13036 !d     &          evdwij
13037               endif
13038 ! Calculate gradient components.
13039               e1=e1*eps1*eps2rt**2*eps3rt**2
13040               fac=-expon*(e1+evdwij)
13041               sigder=fac/sigsq
13042               fac=rrij*fac
13043 ! Calculate radial part of the gradient
13044               gg(1)=xj*fac
13045               gg(2)=yj*fac
13046               gg(3)=zj*fac
13047 ! Calculate the angular part of the gradient and sum add the contributions
13048 ! to the appropriate components of the Cartesian gradient.
13049               call sc_grad_scale(sss)
13050             endif
13051           enddo      ! j
13052         enddo        ! iint
13053       enddo          ! i
13054 !     stop
13055       return
13056       end subroutine ebp_short
13057 !-----------------------------------------------------------------------------
13058       subroutine egb_long(evdw)
13059 !
13060 ! This subroutine calculates the interaction energy of nonbonded side chains
13061 ! assuming the Gay-Berne potential of interaction.
13062 !
13063       use calc_data
13064 !      implicit real*8 (a-h,o-z)
13065 !      include 'DIMENSIONS'
13066 !      include 'COMMON.GEO'
13067 !      include 'COMMON.VAR'
13068 !      include 'COMMON.LOCAL'
13069 !      include 'COMMON.CHAIN'
13070 !      include 'COMMON.DERIV'
13071 !      include 'COMMON.NAMES'
13072 !      include 'COMMON.INTERACT'
13073 !      include 'COMMON.IOUNITS'
13074 !      include 'COMMON.CALC'
13075 !      include 'COMMON.CONTROL'
13076       logical :: lprn
13077 !el local variables
13078       integer :: iint,itypi,itypi1,itypj,subchap
13079       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13080       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13081       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13082                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13083                     ssgradlipi,ssgradlipj
13084
13085
13086       evdw=0.0D0
13087 !cccc      energy_dec=.false.
13088 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13089       evdw=0.0D0
13090       lprn=.false.
13091 !     if (icall.eq.0) lprn=.false.
13092 !el      ind=0
13093       do i=iatsc_s,iatsc_e
13094         itypi=itype(i,1)
13095         if (itypi.eq.ntyp1) cycle
13096         itypi1=itype(i+1,1)
13097         xi=c(1,nres+i)
13098         yi=c(2,nres+i)
13099         zi=c(3,nres+i)
13100           xi=mod(xi,boxxsize)
13101           if (xi.lt.0) xi=xi+boxxsize
13102           yi=mod(yi,boxysize)
13103           if (yi.lt.0) yi=yi+boxysize
13104           zi=mod(zi,boxzsize)
13105           if (zi.lt.0) zi=zi+boxzsize
13106        if ((zi.gt.bordlipbot)    &
13107         .and.(zi.lt.bordliptop)) then
13108 !C the energy transfer exist
13109         if (zi.lt.buflipbot) then
13110 !C what fraction I am in
13111          fracinbuf=1.0d0-    &
13112              ((zi-bordlipbot)/lipbufthick)
13113 !C lipbufthick is thickenes of lipid buffore
13114          sslipi=sscalelip(fracinbuf)
13115          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13116         elseif (zi.gt.bufliptop) then
13117          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13118          sslipi=sscalelip(fracinbuf)
13119          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13120         else
13121          sslipi=1.0d0
13122          ssgradlipi=0.0
13123         endif
13124        else
13125          sslipi=0.0d0
13126          ssgradlipi=0.0
13127        endif
13128
13129         dxi=dc_norm(1,nres+i)
13130         dyi=dc_norm(2,nres+i)
13131         dzi=dc_norm(3,nres+i)
13132 !        dsci_inv=dsc_inv(itypi)
13133         dsci_inv=vbld_inv(i+nres)
13134 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13135 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13136 !
13137 ! Calculate SC interaction energy.
13138 !
13139         do iint=1,nint_gr(i)
13140           do j=istart(i,iint),iend(i,iint)
13141             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13142 !              call dyn_ssbond_ene(i,j,evdwij)
13143 !              evdw=evdw+evdwij
13144 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13145 !                              'evdw',i,j,evdwij,' ss'
13146 !              if (energy_dec) write (iout,*) &
13147 !                              'evdw',i,j,evdwij,' ss'
13148 !             do k=j+1,iend(i,iint)
13149 !C search over all next residues
13150 !              if (dyn_ss_mask(k)) then
13151 !C check if they are cysteins
13152 !C              write(iout,*) 'k=',k
13153
13154 !c              write(iout,*) "PRZED TRI", evdwij
13155 !               evdwij_przed_tri=evdwij
13156 !              call triple_ssbond_ene(i,j,k,evdwij)
13157 !c               if(evdwij_przed_tri.ne.evdwij) then
13158 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13159 !c               endif
13160
13161 !c              write(iout,*) "PO TRI", evdwij
13162 !C call the energy function that removes the artifical triple disulfide
13163 !C bond the soubroutine is located in ssMD.F
13164 !              evdw=evdw+evdwij
13165               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13166                             'evdw',i,j,evdwij,'tss'
13167 !              endif!dyn_ss_mask(k)
13168 !             enddo! k
13169
13170             ELSE
13171 !el            ind=ind+1
13172             itypj=itype(j,1)
13173             if (itypj.eq.ntyp1) cycle
13174 !            dscj_inv=dsc_inv(itypj)
13175             dscj_inv=vbld_inv(j+nres)
13176 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13177 !     &       1.0d0/vbld(j+nres)
13178 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13179             sig0ij=sigma(itypi,itypj)
13180             chi1=chi(itypi,itypj)
13181             chi2=chi(itypj,itypi)
13182             chi12=chi1*chi2
13183             chip1=chip(itypi)
13184             chip2=chip(itypj)
13185             chip12=chip1*chip2
13186             alf1=alp(itypi)
13187             alf2=alp(itypj)
13188             alf12=0.5D0*(alf1+alf2)
13189             xj=c(1,nres+j)
13190             yj=c(2,nres+j)
13191             zj=c(3,nres+j)
13192 ! Searching for nearest neighbour
13193           xj=mod(xj,boxxsize)
13194           if (xj.lt.0) xj=xj+boxxsize
13195           yj=mod(yj,boxysize)
13196           if (yj.lt.0) yj=yj+boxysize
13197           zj=mod(zj,boxzsize)
13198           if (zj.lt.0) zj=zj+boxzsize
13199        if ((zj.gt.bordlipbot)   &
13200       .and.(zj.lt.bordliptop)) then
13201 !C the energy transfer exist
13202         if (zj.lt.buflipbot) then
13203 !C what fraction I am in
13204          fracinbuf=1.0d0-  &
13205              ((zj-bordlipbot)/lipbufthick)
13206 !C lipbufthick is thickenes of lipid buffore
13207          sslipj=sscalelip(fracinbuf)
13208          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13209         elseif (zj.gt.bufliptop) then
13210          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13211          sslipj=sscalelip(fracinbuf)
13212          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13213         else
13214          sslipj=1.0d0
13215          ssgradlipj=0.0
13216         endif
13217        else
13218          sslipj=0.0d0
13219          ssgradlipj=0.0
13220        endif
13221       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13222        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13223       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13224        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13225
13226           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13227           xj_safe=xj
13228           yj_safe=yj
13229           zj_safe=zj
13230           subchap=0
13231           do xshift=-1,1
13232           do yshift=-1,1
13233           do zshift=-1,1
13234           xj=xj_safe+xshift*boxxsize
13235           yj=yj_safe+yshift*boxysize
13236           zj=zj_safe+zshift*boxzsize
13237           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13238           if(dist_temp.lt.dist_init) then
13239             dist_init=dist_temp
13240             xj_temp=xj
13241             yj_temp=yj
13242             zj_temp=zj
13243             subchap=1
13244           endif
13245           enddo
13246           enddo
13247           enddo
13248           if (subchap.eq.1) then
13249           xj=xj_temp-xi
13250           yj=yj_temp-yi
13251           zj=zj_temp-zi
13252           else
13253           xj=xj_safe-xi
13254           yj=yj_safe-yi
13255           zj=zj_safe-zi
13256           endif
13257
13258             dxj=dc_norm(1,nres+j)
13259             dyj=dc_norm(2,nres+j)
13260             dzj=dc_norm(3,nres+j)
13261             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13262             rij=dsqrt(rrij)
13263             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13264             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13265             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13266             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13267             if (sss_ele_cut.le.0.0) cycle
13268             if (sss.lt.1.0d0) then
13269
13270 ! Calculate angle-dependent terms of energy and contributions to their
13271 ! derivatives.
13272               call sc_angular
13273               sigsq=1.0D0/sigsq
13274               sig=sig0ij*dsqrt(sigsq)
13275               rij_shift=1.0D0/rij-sig+sig0ij
13276 ! for diagnostics; uncomment
13277 !              rij_shift=1.2*sig0ij
13278 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13279               if (rij_shift.le.0.0D0) then
13280                 evdw=1.0D20
13281 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13282 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13283 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13284                 return
13285               endif
13286               sigder=-sig*sigsq
13287 !---------------------------------------------------------------
13288               rij_shift=1.0D0/rij_shift
13289               fac=rij_shift**expon
13290               e1=fac*fac*aa
13291               e2=fac*bb
13292               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13293               eps2der=evdwij*eps3rt
13294               eps3der=evdwij*eps2rt
13295 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13296 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13297               evdwij=evdwij*eps2rt*eps3rt
13298               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13299               if (lprn) then
13300               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13301               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13302               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13303                 restyp(itypi,1),i,restyp(itypj,1),j,&
13304                 epsi,sigm,chi1,chi2,chip1,chip2,&
13305                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13306                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13307                 evdwij
13308               endif
13309
13310               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13311                               'evdw',i,j,evdwij
13312 !              if (energy_dec) write (iout,*) &
13313 !                              'evdw',i,j,evdwij,"egb_long"
13314
13315 ! Calculate gradient components.
13316               e1=e1*eps1*eps2rt**2*eps3rt**2
13317               fac=-expon*(e1+evdwij)*rij_shift
13318               sigder=fac*sigder
13319               fac=rij*fac
13320               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13321             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13322             /sigmaii(itypi,itypj))
13323 !              fac=0.0d0
13324 ! Calculate the radial part of the gradient
13325               gg(1)=xj*fac
13326               gg(2)=yj*fac
13327               gg(3)=zj*fac
13328 ! Calculate angular part of the gradient.
13329               call sc_grad_scale(1.0d0-sss)
13330             ENDIF    !mask_dyn_ss
13331             endif
13332           enddo      ! j
13333         enddo        ! iint
13334       enddo          ! i
13335 !      write (iout,*) "Number of loop steps in EGB:",ind
13336 !ccc      energy_dec=.false.
13337       return
13338       end subroutine egb_long
13339 !-----------------------------------------------------------------------------
13340       subroutine egb_short(evdw)
13341 !
13342 ! This subroutine calculates the interaction energy of nonbonded side chains
13343 ! assuming the Gay-Berne potential of interaction.
13344 !
13345       use calc_data
13346 !      implicit real*8 (a-h,o-z)
13347 !      include 'DIMENSIONS'
13348 !      include 'COMMON.GEO'
13349 !      include 'COMMON.VAR'
13350 !      include 'COMMON.LOCAL'
13351 !      include 'COMMON.CHAIN'
13352 !      include 'COMMON.DERIV'
13353 !      include 'COMMON.NAMES'
13354 !      include 'COMMON.INTERACT'
13355 !      include 'COMMON.IOUNITS'
13356 !      include 'COMMON.CALC'
13357 !      include 'COMMON.CONTROL'
13358       logical :: lprn
13359 !el local variables
13360       integer :: iint,itypi,itypi1,itypj,subchap
13361       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13362       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13363       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13364                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13365                     ssgradlipi,ssgradlipj
13366       evdw=0.0D0
13367 !cccc      energy_dec=.false.
13368 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13369       evdw=0.0D0
13370       lprn=.false.
13371 !     if (icall.eq.0) lprn=.false.
13372 !el      ind=0
13373       do i=iatsc_s,iatsc_e
13374         itypi=itype(i,1)
13375         if (itypi.eq.ntyp1) cycle
13376         itypi1=itype(i+1,1)
13377         xi=c(1,nres+i)
13378         yi=c(2,nres+i)
13379         zi=c(3,nres+i)
13380           xi=mod(xi,boxxsize)
13381           if (xi.lt.0) xi=xi+boxxsize
13382           yi=mod(yi,boxysize)
13383           if (yi.lt.0) yi=yi+boxysize
13384           zi=mod(zi,boxzsize)
13385           if (zi.lt.0) zi=zi+boxzsize
13386        if ((zi.gt.bordlipbot)    &
13387         .and.(zi.lt.bordliptop)) then
13388 !C the energy transfer exist
13389         if (zi.lt.buflipbot) then
13390 !C what fraction I am in
13391          fracinbuf=1.0d0-    &
13392              ((zi-bordlipbot)/lipbufthick)
13393 !C lipbufthick is thickenes of lipid buffore
13394          sslipi=sscalelip(fracinbuf)
13395          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13396         elseif (zi.gt.bufliptop) then
13397          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13398          sslipi=sscalelip(fracinbuf)
13399          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13400         else
13401          sslipi=1.0d0
13402          ssgradlipi=0.0
13403         endif
13404        else
13405          sslipi=0.0d0
13406          ssgradlipi=0.0
13407        endif
13408
13409         dxi=dc_norm(1,nres+i)
13410         dyi=dc_norm(2,nres+i)
13411         dzi=dc_norm(3,nres+i)
13412 !        dsci_inv=dsc_inv(itypi)
13413         dsci_inv=vbld_inv(i+nres)
13414
13415         dxi=dc_norm(1,nres+i)
13416         dyi=dc_norm(2,nres+i)
13417         dzi=dc_norm(3,nres+i)
13418 !        dsci_inv=dsc_inv(itypi)
13419         dsci_inv=vbld_inv(i+nres)
13420 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13421 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13422 !
13423 ! Calculate SC interaction energy.
13424 !
13425         do iint=1,nint_gr(i)
13426           do j=istart(i,iint),iend(i,iint)
13427             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13428               call dyn_ssbond_ene(i,j,evdwij)
13429               evdw=evdw+evdwij
13430               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13431                               'evdw',i,j,evdwij,' ss'
13432              do k=j+1,iend(i,iint)
13433 !C search over all next residues
13434               if (dyn_ss_mask(k)) then
13435 !C check if they are cysteins
13436 !C              write(iout,*) 'k=',k
13437
13438 !c              write(iout,*) "PRZED TRI", evdwij
13439 !               evdwij_przed_tri=evdwij
13440               call triple_ssbond_ene(i,j,k,evdwij)
13441 !c               if(evdwij_przed_tri.ne.evdwij) then
13442 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13443 !c               endif
13444
13445 !c              write(iout,*) "PO TRI", evdwij
13446 !C call the energy function that removes the artifical triple disulfide
13447 !C bond the soubroutine is located in ssMD.F
13448               evdw=evdw+evdwij
13449               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13450                             'evdw',i,j,evdwij,'tss'
13451               endif!dyn_ss_mask(k)
13452              enddo! k
13453
13454 !              if (energy_dec) write (iout,*) &
13455 !                              'evdw',i,j,evdwij,' ss'
13456             ELSE
13457 !el            ind=ind+1
13458             itypj=itype(j,1)
13459             if (itypj.eq.ntyp1) cycle
13460 !            dscj_inv=dsc_inv(itypj)
13461             dscj_inv=vbld_inv(j+nres)
13462 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13463 !     &       1.0d0/vbld(j+nres)
13464 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13465             sig0ij=sigma(itypi,itypj)
13466             chi1=chi(itypi,itypj)
13467             chi2=chi(itypj,itypi)
13468             chi12=chi1*chi2
13469             chip1=chip(itypi)
13470             chip2=chip(itypj)
13471             chip12=chip1*chip2
13472             alf1=alp(itypi)
13473             alf2=alp(itypj)
13474             alf12=0.5D0*(alf1+alf2)
13475 !            xj=c(1,nres+j)-xi
13476 !            yj=c(2,nres+j)-yi
13477 !            zj=c(3,nres+j)-zi
13478             xj=c(1,nres+j)
13479             yj=c(2,nres+j)
13480             zj=c(3,nres+j)
13481 ! Searching for nearest neighbour
13482           xj=mod(xj,boxxsize)
13483           if (xj.lt.0) xj=xj+boxxsize
13484           yj=mod(yj,boxysize)
13485           if (yj.lt.0) yj=yj+boxysize
13486           zj=mod(zj,boxzsize)
13487           if (zj.lt.0) zj=zj+boxzsize
13488        if ((zj.gt.bordlipbot)   &
13489       .and.(zj.lt.bordliptop)) then
13490 !C the energy transfer exist
13491         if (zj.lt.buflipbot) then
13492 !C what fraction I am in
13493          fracinbuf=1.0d0-  &
13494              ((zj-bordlipbot)/lipbufthick)
13495 !C lipbufthick is thickenes of lipid buffore
13496          sslipj=sscalelip(fracinbuf)
13497          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13498         elseif (zj.gt.bufliptop) then
13499          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13500          sslipj=sscalelip(fracinbuf)
13501          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13502         else
13503          sslipj=1.0d0
13504          ssgradlipj=0.0
13505         endif
13506        else
13507          sslipj=0.0d0
13508          ssgradlipj=0.0
13509        endif
13510       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13511        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13512       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13513        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13514
13515           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13516           xj_safe=xj
13517           yj_safe=yj
13518           zj_safe=zj
13519           subchap=0
13520
13521           do xshift=-1,1
13522           do yshift=-1,1
13523           do zshift=-1,1
13524           xj=xj_safe+xshift*boxxsize
13525           yj=yj_safe+yshift*boxysize
13526           zj=zj_safe+zshift*boxzsize
13527           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13528           if(dist_temp.lt.dist_init) then
13529             dist_init=dist_temp
13530             xj_temp=xj
13531             yj_temp=yj
13532             zj_temp=zj
13533             subchap=1
13534           endif
13535           enddo
13536           enddo
13537           enddo
13538           if (subchap.eq.1) then
13539           xj=xj_temp-xi
13540           yj=yj_temp-yi
13541           zj=zj_temp-zi
13542           else
13543           xj=xj_safe-xi
13544           yj=yj_safe-yi
13545           zj=zj_safe-zi
13546           endif
13547
13548             dxj=dc_norm(1,nres+j)
13549             dyj=dc_norm(2,nres+j)
13550             dzj=dc_norm(3,nres+j)
13551             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13552             rij=dsqrt(rrij)
13553             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13554             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13555             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13556             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13557             if (sss_ele_cut.le.0.0) cycle
13558
13559             if (sss.gt.0.0d0) then
13560
13561 ! Calculate angle-dependent terms of energy and contributions to their
13562 ! derivatives.
13563               call sc_angular
13564               sigsq=1.0D0/sigsq
13565               sig=sig0ij*dsqrt(sigsq)
13566               rij_shift=1.0D0/rij-sig+sig0ij
13567 ! for diagnostics; uncomment
13568 !              rij_shift=1.2*sig0ij
13569 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13570               if (rij_shift.le.0.0D0) then
13571                 evdw=1.0D20
13572 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13573 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13574 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13575                 return
13576               endif
13577               sigder=-sig*sigsq
13578 !---------------------------------------------------------------
13579               rij_shift=1.0D0/rij_shift
13580               fac=rij_shift**expon
13581               e1=fac*fac*aa
13582               e2=fac*bb
13583               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13584               eps2der=evdwij*eps3rt
13585               eps3der=evdwij*eps2rt
13586 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13587 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13588               evdwij=evdwij*eps2rt*eps3rt
13589               evdw=evdw+evdwij*sss*sss_ele_cut
13590               if (lprn) then
13591               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13592               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13593               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13594                 restyp(itypi,1),i,restyp(itypj,1),j,&
13595                 epsi,sigm,chi1,chi2,chip1,chip2,&
13596                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13597                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13598                 evdwij
13599               endif
13600
13601               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13602                               'evdw',i,j,evdwij
13603 !              if (energy_dec) write (iout,*) &
13604 !                              'evdw',i,j,evdwij,"egb_short"
13605
13606 ! Calculate gradient components.
13607               e1=e1*eps1*eps2rt**2*eps3rt**2
13608               fac=-expon*(e1+evdwij)*rij_shift
13609               sigder=fac*sigder
13610               fac=rij*fac
13611               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13612             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13613             /sigmaii(itypi,itypj))
13614
13615 !              fac=0.0d0
13616 ! Calculate the radial part of the gradient
13617               gg(1)=xj*fac
13618               gg(2)=yj*fac
13619               gg(3)=zj*fac
13620 ! Calculate angular part of the gradient.
13621               call sc_grad_scale(sss)
13622             endif
13623           ENDIF !mask_dyn_ss
13624           enddo      ! j
13625         enddo        ! iint
13626       enddo          ! i
13627 !      write (iout,*) "Number of loop steps in EGB:",ind
13628 !ccc      energy_dec=.false.
13629       return
13630       end subroutine egb_short
13631 !-----------------------------------------------------------------------------
13632       subroutine egbv_long(evdw)
13633 !
13634 ! This subroutine calculates the interaction energy of nonbonded side chains
13635 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13636 !
13637       use calc_data
13638 !      implicit real*8 (a-h,o-z)
13639 !      include 'DIMENSIONS'
13640 !      include 'COMMON.GEO'
13641 !      include 'COMMON.VAR'
13642 !      include 'COMMON.LOCAL'
13643 !      include 'COMMON.CHAIN'
13644 !      include 'COMMON.DERIV'
13645 !      include 'COMMON.NAMES'
13646 !      include 'COMMON.INTERACT'
13647 !      include 'COMMON.IOUNITS'
13648 !      include 'COMMON.CALC'
13649       use comm_srutu
13650 !el      integer :: icall
13651 !el      common /srutu/ icall
13652       logical :: lprn
13653 !el local variables
13654       integer :: iint,itypi,itypi1,itypj
13655       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13656       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13657       evdw=0.0D0
13658 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13659       evdw=0.0D0
13660       lprn=.false.
13661 !     if (icall.eq.0) lprn=.true.
13662 !el      ind=0
13663       do i=iatsc_s,iatsc_e
13664         itypi=itype(i,1)
13665         if (itypi.eq.ntyp1) cycle
13666         itypi1=itype(i+1,1)
13667         xi=c(1,nres+i)
13668         yi=c(2,nres+i)
13669         zi=c(3,nres+i)
13670         dxi=dc_norm(1,nres+i)
13671         dyi=dc_norm(2,nres+i)
13672         dzi=dc_norm(3,nres+i)
13673 !        dsci_inv=dsc_inv(itypi)
13674         dsci_inv=vbld_inv(i+nres)
13675 !
13676 ! Calculate SC interaction energy.
13677 !
13678         do iint=1,nint_gr(i)
13679           do j=istart(i,iint),iend(i,iint)
13680 !el            ind=ind+1
13681             itypj=itype(j,1)
13682             if (itypj.eq.ntyp1) cycle
13683 !            dscj_inv=dsc_inv(itypj)
13684             dscj_inv=vbld_inv(j+nres)
13685             sig0ij=sigma(itypi,itypj)
13686             r0ij=r0(itypi,itypj)
13687             chi1=chi(itypi,itypj)
13688             chi2=chi(itypj,itypi)
13689             chi12=chi1*chi2
13690             chip1=chip(itypi)
13691             chip2=chip(itypj)
13692             chip12=chip1*chip2
13693             alf1=alp(itypi)
13694             alf2=alp(itypj)
13695             alf12=0.5D0*(alf1+alf2)
13696             xj=c(1,nres+j)-xi
13697             yj=c(2,nres+j)-yi
13698             zj=c(3,nres+j)-zi
13699             dxj=dc_norm(1,nres+j)
13700             dyj=dc_norm(2,nres+j)
13701             dzj=dc_norm(3,nres+j)
13702             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13703             rij=dsqrt(rrij)
13704
13705             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13706
13707             if (sss.lt.1.0d0) then
13708
13709 ! Calculate angle-dependent terms of energy and contributions to their
13710 ! derivatives.
13711               call sc_angular
13712               sigsq=1.0D0/sigsq
13713               sig=sig0ij*dsqrt(sigsq)
13714               rij_shift=1.0D0/rij-sig+r0ij
13715 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13716               if (rij_shift.le.0.0D0) then
13717                 evdw=1.0D20
13718                 return
13719               endif
13720               sigder=-sig*sigsq
13721 !---------------------------------------------------------------
13722               rij_shift=1.0D0/rij_shift
13723               fac=rij_shift**expon
13724               e1=fac*fac*aa_aq(itypi,itypj)
13725               e2=fac*bb_aq(itypi,itypj)
13726               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13727               eps2der=evdwij*eps3rt
13728               eps3der=evdwij*eps2rt
13729               fac_augm=rrij**expon
13730               e_augm=augm(itypi,itypj)*fac_augm
13731               evdwij=evdwij*eps2rt*eps3rt
13732               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13733               if (lprn) then
13734               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13735               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13736               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13737                 restyp(itypi,1),i,restyp(itypj,1),j,&
13738                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13739                 chi1,chi2,chip1,chip2,&
13740                 eps1,eps2rt**2,eps3rt**2,&
13741                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13742                 evdwij+e_augm
13743               endif
13744 ! Calculate gradient components.
13745               e1=e1*eps1*eps2rt**2*eps3rt**2
13746               fac=-expon*(e1+evdwij)*rij_shift
13747               sigder=fac*sigder
13748               fac=rij*fac-2*expon*rrij*e_augm
13749 ! Calculate the radial part of the gradient
13750               gg(1)=xj*fac
13751               gg(2)=yj*fac
13752               gg(3)=zj*fac
13753 ! Calculate angular part of the gradient.
13754               call sc_grad_scale(1.0d0-sss)
13755             endif
13756           enddo      ! j
13757         enddo        ! iint
13758       enddo          ! i
13759       end subroutine egbv_long
13760 !-----------------------------------------------------------------------------
13761       subroutine egbv_short(evdw)
13762 !
13763 ! This subroutine calculates the interaction energy of nonbonded side chains
13764 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13765 !
13766       use calc_data
13767 !      implicit real*8 (a-h,o-z)
13768 !      include 'DIMENSIONS'
13769 !      include 'COMMON.GEO'
13770 !      include 'COMMON.VAR'
13771 !      include 'COMMON.LOCAL'
13772 !      include 'COMMON.CHAIN'
13773 !      include 'COMMON.DERIV'
13774 !      include 'COMMON.NAMES'
13775 !      include 'COMMON.INTERACT'
13776 !      include 'COMMON.IOUNITS'
13777 !      include 'COMMON.CALC'
13778       use comm_srutu
13779 !el      integer :: icall
13780 !el      common /srutu/ icall
13781       logical :: lprn
13782 !el local variables
13783       integer :: iint,itypi,itypi1,itypj
13784       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13785       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13786       evdw=0.0D0
13787 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13788       evdw=0.0D0
13789       lprn=.false.
13790 !     if (icall.eq.0) lprn=.true.
13791 !el      ind=0
13792       do i=iatsc_s,iatsc_e
13793         itypi=itype(i,1)
13794         if (itypi.eq.ntyp1) cycle
13795         itypi1=itype(i+1,1)
13796         xi=c(1,nres+i)
13797         yi=c(2,nres+i)
13798         zi=c(3,nres+i)
13799         dxi=dc_norm(1,nres+i)
13800         dyi=dc_norm(2,nres+i)
13801         dzi=dc_norm(3,nres+i)
13802 !        dsci_inv=dsc_inv(itypi)
13803         dsci_inv=vbld_inv(i+nres)
13804 !
13805 ! Calculate SC interaction energy.
13806 !
13807         do iint=1,nint_gr(i)
13808           do j=istart(i,iint),iend(i,iint)
13809 !el            ind=ind+1
13810             itypj=itype(j,1)
13811             if (itypj.eq.ntyp1) cycle
13812 !            dscj_inv=dsc_inv(itypj)
13813             dscj_inv=vbld_inv(j+nres)
13814             sig0ij=sigma(itypi,itypj)
13815             r0ij=r0(itypi,itypj)
13816             chi1=chi(itypi,itypj)
13817             chi2=chi(itypj,itypi)
13818             chi12=chi1*chi2
13819             chip1=chip(itypi)
13820             chip2=chip(itypj)
13821             chip12=chip1*chip2
13822             alf1=alp(itypi)
13823             alf2=alp(itypj)
13824             alf12=0.5D0*(alf1+alf2)
13825             xj=c(1,nres+j)-xi
13826             yj=c(2,nres+j)-yi
13827             zj=c(3,nres+j)-zi
13828             dxj=dc_norm(1,nres+j)
13829             dyj=dc_norm(2,nres+j)
13830             dzj=dc_norm(3,nres+j)
13831             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13832             rij=dsqrt(rrij)
13833
13834             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13835
13836             if (sss.gt.0.0d0) then
13837
13838 ! Calculate angle-dependent terms of energy and contributions to their
13839 ! derivatives.
13840               call sc_angular
13841               sigsq=1.0D0/sigsq
13842               sig=sig0ij*dsqrt(sigsq)
13843               rij_shift=1.0D0/rij-sig+r0ij
13844 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13845               if (rij_shift.le.0.0D0) then
13846                 evdw=1.0D20
13847                 return
13848               endif
13849               sigder=-sig*sigsq
13850 !---------------------------------------------------------------
13851               rij_shift=1.0D0/rij_shift
13852               fac=rij_shift**expon
13853               e1=fac*fac*aa_aq(itypi,itypj)
13854               e2=fac*bb_aq(itypi,itypj)
13855               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13856               eps2der=evdwij*eps3rt
13857               eps3der=evdwij*eps2rt
13858               fac_augm=rrij**expon
13859               e_augm=augm(itypi,itypj)*fac_augm
13860               evdwij=evdwij*eps2rt*eps3rt
13861               evdw=evdw+(evdwij+e_augm)*sss
13862               if (lprn) then
13863               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13864               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13865               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13866                 restyp(itypi,1),i,restyp(itypj,1),j,&
13867                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13868                 chi1,chi2,chip1,chip2,&
13869                 eps1,eps2rt**2,eps3rt**2,&
13870                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13871                 evdwij+e_augm
13872               endif
13873 ! Calculate gradient components.
13874               e1=e1*eps1*eps2rt**2*eps3rt**2
13875               fac=-expon*(e1+evdwij)*rij_shift
13876               sigder=fac*sigder
13877               fac=rij*fac-2*expon*rrij*e_augm
13878 ! Calculate the radial part of the gradient
13879               gg(1)=xj*fac
13880               gg(2)=yj*fac
13881               gg(3)=zj*fac
13882 ! Calculate angular part of the gradient.
13883               call sc_grad_scale(sss)
13884             endif
13885           enddo      ! j
13886         enddo        ! iint
13887       enddo          ! i
13888       end subroutine egbv_short
13889 !-----------------------------------------------------------------------------
13890       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13891 !
13892 ! This subroutine calculates the average interaction energy and its gradient
13893 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13894 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13895 ! The potential depends both on the distance of peptide-group centers and on
13896 ! the orientation of the CA-CA virtual bonds.
13897 !
13898 !      implicit real*8 (a-h,o-z)
13899
13900       use comm_locel
13901 #ifdef MPI
13902       include 'mpif.h'
13903 #endif
13904 !      include 'DIMENSIONS'
13905 !      include 'COMMON.CONTROL'
13906 !      include 'COMMON.SETUP'
13907 !      include 'COMMON.IOUNITS'
13908 !      include 'COMMON.GEO'
13909 !      include 'COMMON.VAR'
13910 !      include 'COMMON.LOCAL'
13911 !      include 'COMMON.CHAIN'
13912 !      include 'COMMON.DERIV'
13913 !      include 'COMMON.INTERACT'
13914 !      include 'COMMON.CONTACTS'
13915 !      include 'COMMON.TORSION'
13916 !      include 'COMMON.VECTORS'
13917 !      include 'COMMON.FFIELD'
13918 !      include 'COMMON.TIME1'
13919       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13920       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13921       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13922 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13923       real(kind=8),dimension(4) :: muij
13924 !el      integer :: num_conti,j1,j2
13925 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13926 !el                   dz_normi,xmedi,ymedi,zmedi
13927 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13928 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13929 !el          num_conti,j1,j2
13930 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13931 #ifdef MOMENT
13932       real(kind=8) :: scal_el=1.0d0
13933 #else
13934       real(kind=8) :: scal_el=0.5d0
13935 #endif
13936 ! 12/13/98
13937 ! 13-go grudnia roku pamietnego...
13938       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13939                                              0.0d0,1.0d0,0.0d0,&
13940                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13941 !el local variables
13942       integer :: i,j,k
13943       real(kind=8) :: fac
13944       real(kind=8) :: dxj,dyj,dzj
13945       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13946
13947 !      allocate(num_cont_hb(nres)) !(maxres)
13948 !d      write(iout,*) 'In EELEC'
13949 !d      do i=1,nloctyp
13950 !d        write(iout,*) 'Type',i
13951 !d        write(iout,*) 'B1',B1(:,i)
13952 !d        write(iout,*) 'B2',B2(:,i)
13953 !d        write(iout,*) 'CC',CC(:,:,i)
13954 !d        write(iout,*) 'DD',DD(:,:,i)
13955 !d        write(iout,*) 'EE',EE(:,:,i)
13956 !d      enddo
13957 !d      call check_vecgrad
13958 !d      stop
13959       if (icheckgrad.eq.1) then
13960         do i=1,nres-1
13961           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13962           do k=1,3
13963             dc_norm(k,i)=dc(k,i)*fac
13964           enddo
13965 !          write (iout,*) 'i',i,' fac',fac
13966         enddo
13967       endif
13968       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13969           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13970           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13971 !        call vec_and_deriv
13972 #ifdef TIMING
13973         time01=MPI_Wtime()
13974 #endif
13975 !        print *, "before set matrices"
13976         call set_matrices
13977 !        print *,"after set martices"
13978 #ifdef TIMING
13979         time_mat=time_mat+MPI_Wtime()-time01
13980 #endif
13981       endif
13982 !d      do i=1,nres-1
13983 !d        write (iout,*) 'i=',i
13984 !d        do k=1,3
13985 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
13986 !d        enddo
13987 !d        do k=1,3
13988 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
13989 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
13990 !d        enddo
13991 !d      enddo
13992       t_eelecij=0.0d0
13993       ees=0.0D0
13994       evdw1=0.0D0
13995       eel_loc=0.0d0
13996       eello_turn3=0.0d0
13997       eello_turn4=0.0d0
13998 !el      ind=0
13999       do i=1,nres
14000         num_cont_hb(i)=0
14001       enddo
14002 !d      print '(a)','Enter EELEC'
14003 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14004 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14005 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14006       do i=1,nres
14007         gel_loc_loc(i)=0.0d0
14008         gcorr_loc(i)=0.0d0
14009       enddo
14010 !
14011 !
14012 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14013 !
14014 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14015 !
14016       do i=iturn3_start,iturn3_end
14017         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14018         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14019         dxi=dc(1,i)
14020         dyi=dc(2,i)
14021         dzi=dc(3,i)
14022         dx_normi=dc_norm(1,i)
14023         dy_normi=dc_norm(2,i)
14024         dz_normi=dc_norm(3,i)
14025         xmedi=c(1,i)+0.5d0*dxi
14026         ymedi=c(2,i)+0.5d0*dyi
14027         zmedi=c(3,i)+0.5d0*dzi
14028           xmedi=dmod(xmedi,boxxsize)
14029           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14030           ymedi=dmod(ymedi,boxysize)
14031           if (ymedi.lt.0) ymedi=ymedi+boxysize
14032           zmedi=dmod(zmedi,boxzsize)
14033           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14034         num_conti=0
14035         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14036         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14037         num_cont_hb(i)=num_conti
14038       enddo
14039       do i=iturn4_start,iturn4_end
14040         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14041           .or. itype(i+3,1).eq.ntyp1 &
14042           .or. itype(i+4,1).eq.ntyp1) cycle
14043         dxi=dc(1,i)
14044         dyi=dc(2,i)
14045         dzi=dc(3,i)
14046         dx_normi=dc_norm(1,i)
14047         dy_normi=dc_norm(2,i)
14048         dz_normi=dc_norm(3,i)
14049         xmedi=c(1,i)+0.5d0*dxi
14050         ymedi=c(2,i)+0.5d0*dyi
14051         zmedi=c(3,i)+0.5d0*dzi
14052           xmedi=dmod(xmedi,boxxsize)
14053           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14054           ymedi=dmod(ymedi,boxysize)
14055           if (ymedi.lt.0) ymedi=ymedi+boxysize
14056           zmedi=dmod(zmedi,boxzsize)
14057           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14058         num_conti=num_cont_hb(i)
14059         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14060         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14061           call eturn4(i,eello_turn4)
14062         num_cont_hb(i)=num_conti
14063       enddo   ! i
14064 !
14065 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14066 !
14067       do i=iatel_s,iatel_e
14068         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14069         dxi=dc(1,i)
14070         dyi=dc(2,i)
14071         dzi=dc(3,i)
14072         dx_normi=dc_norm(1,i)
14073         dy_normi=dc_norm(2,i)
14074         dz_normi=dc_norm(3,i)
14075         xmedi=c(1,i)+0.5d0*dxi
14076         ymedi=c(2,i)+0.5d0*dyi
14077         zmedi=c(3,i)+0.5d0*dzi
14078           xmedi=dmod(xmedi,boxxsize)
14079           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14080           ymedi=dmod(ymedi,boxysize)
14081           if (ymedi.lt.0) ymedi=ymedi+boxysize
14082           zmedi=dmod(zmedi,boxzsize)
14083           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14084 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14085         num_conti=num_cont_hb(i)
14086         do j=ielstart(i),ielend(i)
14087           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14088           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14089         enddo ! j
14090         num_cont_hb(i)=num_conti
14091       enddo   ! i
14092 !      write (iout,*) "Number of loop steps in EELEC:",ind
14093 !d      do i=1,nres
14094 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14095 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14096 !d      enddo
14097 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14098 !cc      eel_loc=eel_loc+eello_turn3
14099 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14100       return
14101       end subroutine eelec_scale
14102 !-----------------------------------------------------------------------------
14103       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14104 !      implicit real*8 (a-h,o-z)
14105
14106       use comm_locel
14107 !      include 'DIMENSIONS'
14108 #ifdef MPI
14109       include "mpif.h"
14110 #endif
14111 !      include 'COMMON.CONTROL'
14112 !      include 'COMMON.IOUNITS'
14113 !      include 'COMMON.GEO'
14114 !      include 'COMMON.VAR'
14115 !      include 'COMMON.LOCAL'
14116 !      include 'COMMON.CHAIN'
14117 !      include 'COMMON.DERIV'
14118 !      include 'COMMON.INTERACT'
14119 !      include 'COMMON.CONTACTS'
14120 !      include 'COMMON.TORSION'
14121 !      include 'COMMON.VECTORS'
14122 !      include 'COMMON.FFIELD'
14123 !      include 'COMMON.TIME1'
14124       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14125       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14126       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14127 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14128       real(kind=8),dimension(4) :: muij
14129       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14130                     dist_temp, dist_init,sss_grad
14131       integer xshift,yshift,zshift
14132
14133 !el      integer :: num_conti,j1,j2
14134 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14135 !el                   dz_normi,xmedi,ymedi,zmedi
14136 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14137 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14138 !el          num_conti,j1,j2
14139 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14140 #ifdef MOMENT
14141       real(kind=8) :: scal_el=1.0d0
14142 #else
14143       real(kind=8) :: scal_el=0.5d0
14144 #endif
14145 ! 12/13/98
14146 ! 13-go grudnia roku pamietnego...
14147       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14148                                              0.0d0,1.0d0,0.0d0,&
14149                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14150 !el local variables
14151       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14152       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14153       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14154       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14155       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14156       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14157       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14158                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14159                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14160                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14161                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14162                   ecosam,ecosbm,ecosgm,ghalf,time00
14163 !      integer :: maxconts
14164 !      maxconts = nres/4
14165 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14166 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14167 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14168 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14169 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14170 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14171 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14172 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14173 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14174 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14175 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14176 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14177 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14178
14179 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14180 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14181
14182 #ifdef MPI
14183           time00=MPI_Wtime()
14184 #endif
14185 !d      write (iout,*) "eelecij",i,j
14186 !el          ind=ind+1
14187           iteli=itel(i)
14188           itelj=itel(j)
14189           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14190           aaa=app(iteli,itelj)
14191           bbb=bpp(iteli,itelj)
14192           ael6i=ael6(iteli,itelj)
14193           ael3i=ael3(iteli,itelj)
14194           dxj=dc(1,j)
14195           dyj=dc(2,j)
14196           dzj=dc(3,j)
14197           dx_normj=dc_norm(1,j)
14198           dy_normj=dc_norm(2,j)
14199           dz_normj=dc_norm(3,j)
14200 !          xj=c(1,j)+0.5D0*dxj-xmedi
14201 !          yj=c(2,j)+0.5D0*dyj-ymedi
14202 !          zj=c(3,j)+0.5D0*dzj-zmedi
14203           xj=c(1,j)+0.5D0*dxj
14204           yj=c(2,j)+0.5D0*dyj
14205           zj=c(3,j)+0.5D0*dzj
14206           xj=mod(xj,boxxsize)
14207           if (xj.lt.0) xj=xj+boxxsize
14208           yj=mod(yj,boxysize)
14209           if (yj.lt.0) yj=yj+boxysize
14210           zj=mod(zj,boxzsize)
14211           if (zj.lt.0) zj=zj+boxzsize
14212       isubchap=0
14213       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14214       xj_safe=xj
14215       yj_safe=yj
14216       zj_safe=zj
14217       do xshift=-1,1
14218       do yshift=-1,1
14219       do zshift=-1,1
14220           xj=xj_safe+xshift*boxxsize
14221           yj=yj_safe+yshift*boxysize
14222           zj=zj_safe+zshift*boxzsize
14223           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14224           if(dist_temp.lt.dist_init) then
14225             dist_init=dist_temp
14226             xj_temp=xj
14227             yj_temp=yj
14228             zj_temp=zj
14229             isubchap=1
14230           endif
14231        enddo
14232        enddo
14233        enddo
14234        if (isubchap.eq.1) then
14235 !C          print *,i,j
14236           xj=xj_temp-xmedi
14237           yj=yj_temp-ymedi
14238           zj=zj_temp-zmedi
14239        else
14240           xj=xj_safe-xmedi
14241           yj=yj_safe-ymedi
14242           zj=zj_safe-zmedi
14243        endif
14244
14245           rij=xj*xj+yj*yj+zj*zj
14246           rrmij=1.0D0/rij
14247           rij=dsqrt(rij)
14248           rmij=1.0D0/rij
14249 ! For extracting the short-range part of Evdwpp
14250           sss=sscale(rij/rpp(iteli,itelj))
14251             sss_ele_cut=sscale_ele(rij)
14252             sss_ele_grad=sscagrad_ele(rij)
14253             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14254 !             sss_ele_cut=1.0d0
14255 !             sss_ele_grad=0.0d0
14256             if (sss_ele_cut.le.0.0) go to 128
14257
14258           r3ij=rrmij*rmij
14259           r6ij=r3ij*r3ij
14260           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14261           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14262           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14263           fac=cosa-3.0D0*cosb*cosg
14264           ev1=aaa*r6ij*r6ij
14265 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14266           if (j.eq.i+2) ev1=scal_el*ev1
14267           ev2=bbb*r6ij
14268           fac3=ael6i*r6ij
14269           fac4=ael3i*r3ij
14270           evdwij=ev1+ev2
14271           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14272           el2=fac4*fac
14273           eesij=el1+el2
14274 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14275           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14276           ees=ees+eesij*sss_ele_cut
14277           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14278 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14279 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14280 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14281 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14282
14283           if (energy_dec) then
14284               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14285               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14286           endif
14287
14288 !
14289 ! Calculate contributions to the Cartesian gradient.
14290 !
14291 #ifdef SPLITELE
14292           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14293           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14294           fac1=fac
14295           erij(1)=xj*rmij
14296           erij(2)=yj*rmij
14297           erij(3)=zj*rmij
14298 !
14299 ! Radial derivatives. First process both termini of the fragment (i,j)
14300 !
14301           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14302           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14303           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14304 !          do k=1,3
14305 !            ghalf=0.5D0*ggg(k)
14306 !            gelc(k,i)=gelc(k,i)+ghalf
14307 !            gelc(k,j)=gelc(k,j)+ghalf
14308 !          enddo
14309 ! 9/28/08 AL Gradient compotents will be summed only at the end
14310           do k=1,3
14311             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14312             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14313           enddo
14314 !
14315 ! Loop over residues i+1 thru j-1.
14316 !
14317 !grad          do k=i+1,j-1
14318 !grad            do l=1,3
14319 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14320 !grad            enddo
14321 !grad          enddo
14322           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14323           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14324           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14325           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14326           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14327           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14328 !          do k=1,3
14329 !            ghalf=0.5D0*ggg(k)
14330 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14331 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14332 !          enddo
14333 ! 9/28/08 AL Gradient compotents will be summed only at the end
14334           do k=1,3
14335             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14336             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14337           enddo
14338 !
14339 ! Loop over residues i+1 thru j-1.
14340 !
14341 !grad          do k=i+1,j-1
14342 !grad            do l=1,3
14343 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14344 !grad            enddo
14345 !grad          enddo
14346 #else
14347           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14348           facel=(el1+eesij)*sss_ele_cut
14349           fac1=fac
14350           fac=-3*rrmij*(facvdw+facvdw+facel)
14351           erij(1)=xj*rmij
14352           erij(2)=yj*rmij
14353           erij(3)=zj*rmij
14354 !
14355 ! Radial derivatives. First process both termini of the fragment (i,j)
14356 !
14357           ggg(1)=fac*xj
14358           ggg(2)=fac*yj
14359           ggg(3)=fac*zj
14360 !          do k=1,3
14361 !            ghalf=0.5D0*ggg(k)
14362 !            gelc(k,i)=gelc(k,i)+ghalf
14363 !            gelc(k,j)=gelc(k,j)+ghalf
14364 !          enddo
14365 ! 9/28/08 AL Gradient compotents will be summed only at the end
14366           do k=1,3
14367             gelc_long(k,j)=gelc(k,j)+ggg(k)
14368             gelc_long(k,i)=gelc(k,i)-ggg(k)
14369           enddo
14370 !
14371 ! Loop over residues i+1 thru j-1.
14372 !
14373 !grad          do k=i+1,j-1
14374 !grad            do l=1,3
14375 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14376 !grad            enddo
14377 !grad          enddo
14378 ! 9/28/08 AL Gradient compotents will be summed only at the end
14379           ggg(1)=facvdw*xj
14380           ggg(2)=facvdw*yj
14381           ggg(3)=facvdw*zj
14382           do k=1,3
14383             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14384             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14385           enddo
14386 #endif
14387 !
14388 ! Angular part
14389 !
14390           ecosa=2.0D0*fac3*fac1+fac4
14391           fac4=-3.0D0*fac4
14392           fac3=-6.0D0*fac3
14393           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14394           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14395           do k=1,3
14396             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14397             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14398           enddo
14399 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14400 !d   &          (dcosg(k),k=1,3)
14401           do k=1,3
14402             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14403           enddo
14404 !          do k=1,3
14405 !            ghalf=0.5D0*ggg(k)
14406 !            gelc(k,i)=gelc(k,i)+ghalf
14407 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14408 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14409 !            gelc(k,j)=gelc(k,j)+ghalf
14410 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14411 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14412 !          enddo
14413 !grad          do k=i+1,j-1
14414 !grad            do l=1,3
14415 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14416 !grad            enddo
14417 !grad          enddo
14418           do k=1,3
14419             gelc(k,i)=gelc(k,i) &
14420                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14421                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14422                      *sss_ele_cut
14423             gelc(k,j)=gelc(k,j) &
14424                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14425                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14426                      *sss_ele_cut
14427             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14428             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14429           enddo
14430           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14431               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14432               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14433 !
14434 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14435 !   energy of a peptide unit is assumed in the form of a second-order
14436 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14437 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14438 !   are computed for EVERY pair of non-contiguous peptide groups.
14439 !
14440           if (j.lt.nres-1) then
14441             j1=j+1
14442             j2=j-1
14443           else
14444             j1=j-1
14445             j2=j-2
14446           endif
14447           kkk=0
14448           do k=1,2
14449             do l=1,2
14450               kkk=kkk+1
14451               muij(kkk)=mu(k,i)*mu(l,j)
14452             enddo
14453           enddo
14454 !d         write (iout,*) 'EELEC: i',i,' j',j
14455 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14456 !d          write(iout,*) 'muij',muij
14457           ury=scalar(uy(1,i),erij)
14458           urz=scalar(uz(1,i),erij)
14459           vry=scalar(uy(1,j),erij)
14460           vrz=scalar(uz(1,j),erij)
14461           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14462           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14463           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14464           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14465           fac=dsqrt(-ael6i)*r3ij
14466           a22=a22*fac
14467           a23=a23*fac
14468           a32=a32*fac
14469           a33=a33*fac
14470 !d          write (iout,'(4i5,4f10.5)')
14471 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14472 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14473 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14474 !d     &      uy(:,j),uz(:,j)
14475 !d          write (iout,'(4f10.5)')
14476 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14477 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14478 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14479 !d           write (iout,'(9f10.5/)')
14480 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14481 ! Derivatives of the elements of A in virtual-bond vectors
14482           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14483           do k=1,3
14484             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14485             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14486             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14487             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14488             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14489             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14490             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14491             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14492             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14493             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14494             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14495             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14496           enddo
14497 ! Compute radial contributions to the gradient
14498           facr=-3.0d0*rrmij
14499           a22der=a22*facr
14500           a23der=a23*facr
14501           a32der=a32*facr
14502           a33der=a33*facr
14503           agg(1,1)=a22der*xj
14504           agg(2,1)=a22der*yj
14505           agg(3,1)=a22der*zj
14506           agg(1,2)=a23der*xj
14507           agg(2,2)=a23der*yj
14508           agg(3,2)=a23der*zj
14509           agg(1,3)=a32der*xj
14510           agg(2,3)=a32der*yj
14511           agg(3,3)=a32der*zj
14512           agg(1,4)=a33der*xj
14513           agg(2,4)=a33der*yj
14514           agg(3,4)=a33der*zj
14515 ! Add the contributions coming from er
14516           fac3=-3.0d0*fac
14517           do k=1,3
14518             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14519             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14520             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14521             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14522           enddo
14523           do k=1,3
14524 ! Derivatives in DC(i)
14525 !grad            ghalf1=0.5d0*agg(k,1)
14526 !grad            ghalf2=0.5d0*agg(k,2)
14527 !grad            ghalf3=0.5d0*agg(k,3)
14528 !grad            ghalf4=0.5d0*agg(k,4)
14529             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14530             -3.0d0*uryg(k,2)*vry)!+ghalf1
14531             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14532             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14533             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14534             -3.0d0*urzg(k,2)*vry)!+ghalf3
14535             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14536             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14537 ! Derivatives in DC(i+1)
14538             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14539             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14540             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14541             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14542             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14543             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14544             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14545             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14546 ! Derivatives in DC(j)
14547             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14548             -3.0d0*vryg(k,2)*ury)!+ghalf1
14549             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14550             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14551             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14552             -3.0d0*vryg(k,2)*urz)!+ghalf3
14553             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14554             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14555 ! Derivatives in DC(j+1) or DC(nres-1)
14556             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14557             -3.0d0*vryg(k,3)*ury)
14558             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14559             -3.0d0*vrzg(k,3)*ury)
14560             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14561             -3.0d0*vryg(k,3)*urz)
14562             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14563             -3.0d0*vrzg(k,3)*urz)
14564 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14565 !grad              do l=1,4
14566 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14567 !grad              enddo
14568 !grad            endif
14569           enddo
14570           acipa(1,1)=a22
14571           acipa(1,2)=a23
14572           acipa(2,1)=a32
14573           acipa(2,2)=a33
14574           a22=-a22
14575           a23=-a23
14576           do l=1,2
14577             do k=1,3
14578               agg(k,l)=-agg(k,l)
14579               aggi(k,l)=-aggi(k,l)
14580               aggi1(k,l)=-aggi1(k,l)
14581               aggj(k,l)=-aggj(k,l)
14582               aggj1(k,l)=-aggj1(k,l)
14583             enddo
14584           enddo
14585           if (j.lt.nres-1) then
14586             a22=-a22
14587             a32=-a32
14588             do l=1,3,2
14589               do k=1,3
14590                 agg(k,l)=-agg(k,l)
14591                 aggi(k,l)=-aggi(k,l)
14592                 aggi1(k,l)=-aggi1(k,l)
14593                 aggj(k,l)=-aggj(k,l)
14594                 aggj1(k,l)=-aggj1(k,l)
14595               enddo
14596             enddo
14597           else
14598             a22=-a22
14599             a23=-a23
14600             a32=-a32
14601             a33=-a33
14602             do l=1,4
14603               do k=1,3
14604                 agg(k,l)=-agg(k,l)
14605                 aggi(k,l)=-aggi(k,l)
14606                 aggi1(k,l)=-aggi1(k,l)
14607                 aggj(k,l)=-aggj(k,l)
14608                 aggj1(k,l)=-aggj1(k,l)
14609               enddo
14610             enddo
14611           endif
14612           ENDIF ! WCORR
14613           IF (wel_loc.gt.0.0d0) THEN
14614 ! Contribution to the local-electrostatic energy coming from the i-j pair
14615           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14616            +a33*muij(4)
14617 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14618
14619           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14620                   'eelloc',i,j,eel_loc_ij
14621 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14622
14623           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14624 ! Partial derivatives in virtual-bond dihedral angles gamma
14625           if (i.gt.1) &
14626           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14627                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14628                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14629                  *sss_ele_cut
14630           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14631                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14632                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14633                  *sss_ele_cut
14634            xtemp(1)=xj
14635            xtemp(2)=yj
14636            xtemp(3)=zj
14637
14638 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14639           do l=1,3
14640             ggg(l)=(agg(l,1)*muij(1)+ &
14641                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14642             *sss_ele_cut &
14643              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14644
14645             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14646             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14647 !grad            ghalf=0.5d0*ggg(l)
14648 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14649 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14650           enddo
14651 !grad          do k=i+1,j2
14652 !grad            do l=1,3
14653 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14654 !grad            enddo
14655 !grad          enddo
14656 ! Remaining derivatives of eello
14657           do l=1,3
14658             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14659                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14660             *sss_ele_cut
14661
14662             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14663                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14664             *sss_ele_cut
14665
14666             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14667                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14668             *sss_ele_cut
14669
14670             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14671                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14672             *sss_ele_cut
14673
14674           enddo
14675           ENDIF
14676 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14677 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14678           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14679              .and. num_conti.le.maxconts) then
14680 !            write (iout,*) i,j," entered corr"
14681 !
14682 ! Calculate the contact function. The ith column of the array JCONT will
14683 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14684 ! greater than I). The arrays FACONT and GACONT will contain the values of
14685 ! the contact function and its derivative.
14686 !           r0ij=1.02D0*rpp(iteli,itelj)
14687 !           r0ij=1.11D0*rpp(iteli,itelj)
14688             r0ij=2.20D0*rpp(iteli,itelj)
14689 !           r0ij=1.55D0*rpp(iteli,itelj)
14690             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14691 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14692             if (fcont.gt.0.0D0) then
14693               num_conti=num_conti+1
14694               if (num_conti.gt.maxconts) then
14695 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14696                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14697                                ' will skip next contacts for this conf.',num_conti
14698               else
14699                 jcont_hb(num_conti,i)=j
14700 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14701 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14702                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14703                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14704 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14705 !  terms.
14706                 d_cont(num_conti,i)=rij
14707 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14708 !     --- Electrostatic-interaction matrix ---
14709                 a_chuj(1,1,num_conti,i)=a22
14710                 a_chuj(1,2,num_conti,i)=a23
14711                 a_chuj(2,1,num_conti,i)=a32
14712                 a_chuj(2,2,num_conti,i)=a33
14713 !     --- Gradient of rij
14714                 do kkk=1,3
14715                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14716                 enddo
14717                 kkll=0
14718                 do k=1,2
14719                   do l=1,2
14720                     kkll=kkll+1
14721                     do m=1,3
14722                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14723                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14724                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14725                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14726                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14727                     enddo
14728                   enddo
14729                 enddo
14730                 ENDIF
14731                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14732 ! Calculate contact energies
14733                 cosa4=4.0D0*cosa
14734                 wij=cosa-3.0D0*cosb*cosg
14735                 cosbg1=cosb+cosg
14736                 cosbg2=cosb-cosg
14737 !               fac3=dsqrt(-ael6i)/r0ij**3
14738                 fac3=dsqrt(-ael6i)*r3ij
14739 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14740                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14741                 if (ees0tmp.gt.0) then
14742                   ees0pij=dsqrt(ees0tmp)
14743                 else
14744                   ees0pij=0
14745                 endif
14746 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14747                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14748                 if (ees0tmp.gt.0) then
14749                   ees0mij=dsqrt(ees0tmp)
14750                 else
14751                   ees0mij=0
14752                 endif
14753 !               ees0mij=0.0D0
14754                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14755                      *sss_ele_cut
14756
14757                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14758                      *sss_ele_cut
14759
14760 ! Diagnostics. Comment out or remove after debugging!
14761 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14762 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14763 !               ees0m(num_conti,i)=0.0D0
14764 ! End diagnostics.
14765 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14766 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14767 ! Angular derivatives of the contact function
14768                 ees0pij1=fac3/ees0pij
14769                 ees0mij1=fac3/ees0mij
14770                 fac3p=-3.0D0*fac3*rrmij
14771                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14772                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14773 !               ees0mij1=0.0D0
14774                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14775                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14776                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14777                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14778                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14779                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14780                 ecosap=ecosa1+ecosa2
14781                 ecosbp=ecosb1+ecosb2
14782                 ecosgp=ecosg1+ecosg2
14783                 ecosam=ecosa1-ecosa2
14784                 ecosbm=ecosb1-ecosb2
14785                 ecosgm=ecosg1-ecosg2
14786 ! Diagnostics
14787 !               ecosap=ecosa1
14788 !               ecosbp=ecosb1
14789 !               ecosgp=ecosg1
14790 !               ecosam=0.0D0
14791 !               ecosbm=0.0D0
14792 !               ecosgm=0.0D0
14793 ! End diagnostics
14794                 facont_hb(num_conti,i)=fcont
14795                 fprimcont=fprimcont/rij
14796 !d              facont_hb(num_conti,i)=1.0D0
14797 ! Following line is for diagnostics.
14798 !d              fprimcont=0.0D0
14799                 do k=1,3
14800                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14801                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14802                 enddo
14803                 do k=1,3
14804                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14805                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14806                 enddo
14807 !                gggp(1)=gggp(1)+ees0pijp*xj
14808 !                gggp(2)=gggp(2)+ees0pijp*yj
14809 !                gggp(3)=gggp(3)+ees0pijp*zj
14810 !                gggm(1)=gggm(1)+ees0mijp*xj
14811 !                gggm(2)=gggm(2)+ees0mijp*yj
14812 !                gggm(3)=gggm(3)+ees0mijp*zj
14813                 gggp(1)=gggp(1)+ees0pijp*xj &
14814                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14815                 gggp(2)=gggp(2)+ees0pijp*yj &
14816                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14817                 gggp(3)=gggp(3)+ees0pijp*zj &
14818                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14819
14820                 gggm(1)=gggm(1)+ees0mijp*xj &
14821                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14822
14823                 gggm(2)=gggm(2)+ees0mijp*yj &
14824                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14825
14826                 gggm(3)=gggm(3)+ees0mijp*zj &
14827                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14828
14829 ! Derivatives due to the contact function
14830                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14831                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14832                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14833                 do k=1,3
14834 !
14835 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14836 !          following the change of gradient-summation algorithm.
14837 !
14838 !grad                  ghalfp=0.5D0*gggp(k)
14839 !grad                  ghalfm=0.5D0*gggm(k)
14840 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14841 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14842 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14843 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14844 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14845 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14846 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14847 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14848 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14849 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14850 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14851 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14852 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14853 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14854                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14855                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14856                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14857                      *sss_ele_cut
14858
14859                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14860                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14861                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14862                      *sss_ele_cut
14863
14864                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14865                      *sss_ele_cut
14866
14867                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14868                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14869                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14870                      *sss_ele_cut
14871
14872                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14873                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14874                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14875                      *sss_ele_cut
14876
14877                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14878                      *sss_ele_cut
14879
14880                 enddo
14881               ENDIF ! wcorr
14882               endif  ! num_conti.le.maxconts
14883             endif  ! fcont.gt.0
14884           endif    ! j.gt.i+1
14885           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14886             do k=1,4
14887               do l=1,3
14888                 ghalf=0.5d0*agg(l,k)
14889                 aggi(l,k)=aggi(l,k)+ghalf
14890                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14891                 aggj(l,k)=aggj(l,k)+ghalf
14892               enddo
14893             enddo
14894             if (j.eq.nres-1 .and. i.lt.j-2) then
14895               do k=1,4
14896                 do l=1,3
14897                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14898                 enddo
14899               enddo
14900             endif
14901           endif
14902  128      continue
14903 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14904       return
14905       end subroutine eelecij_scale
14906 !-----------------------------------------------------------------------------
14907       subroutine evdwpp_short(evdw1)
14908 !
14909 ! Compute Evdwpp
14910 !
14911 !      implicit real*8 (a-h,o-z)
14912 !      include 'DIMENSIONS'
14913 !      include 'COMMON.CONTROL'
14914 !      include 'COMMON.IOUNITS'
14915 !      include 'COMMON.GEO'
14916 !      include 'COMMON.VAR'
14917 !      include 'COMMON.LOCAL'
14918 !      include 'COMMON.CHAIN'
14919 !      include 'COMMON.DERIV'
14920 !      include 'COMMON.INTERACT'
14921 !      include 'COMMON.CONTACTS'
14922 !      include 'COMMON.TORSION'
14923 !      include 'COMMON.VECTORS'
14924 !      include 'COMMON.FFIELD'
14925       real(kind=8),dimension(3) :: ggg
14926 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14927 #ifdef MOMENT
14928       real(kind=8) :: scal_el=1.0d0
14929 #else
14930       real(kind=8) :: scal_el=0.5d0
14931 #endif
14932 !el local variables
14933       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14934       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14935       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14936                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14937                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14938       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14939                     dist_temp, dist_init,sss_grad
14940       integer xshift,yshift,zshift
14941
14942
14943       evdw1=0.0D0
14944 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14945 !     & " iatel_e_vdw",iatel_e_vdw
14946       call flush(iout)
14947       do i=iatel_s_vdw,iatel_e_vdw
14948         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14949         dxi=dc(1,i)
14950         dyi=dc(2,i)
14951         dzi=dc(3,i)
14952         dx_normi=dc_norm(1,i)
14953         dy_normi=dc_norm(2,i)
14954         dz_normi=dc_norm(3,i)
14955         xmedi=c(1,i)+0.5d0*dxi
14956         ymedi=c(2,i)+0.5d0*dyi
14957         zmedi=c(3,i)+0.5d0*dzi
14958           xmedi=dmod(xmedi,boxxsize)
14959           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14960           ymedi=dmod(ymedi,boxysize)
14961           if (ymedi.lt.0) ymedi=ymedi+boxysize
14962           zmedi=dmod(zmedi,boxzsize)
14963           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14964         num_conti=0
14965 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14966 !     &   ' ielend',ielend_vdw(i)
14967         call flush(iout)
14968         do j=ielstart_vdw(i),ielend_vdw(i)
14969           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14970 !el          ind=ind+1
14971           iteli=itel(i)
14972           itelj=itel(j)
14973           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14974           aaa=app(iteli,itelj)
14975           bbb=bpp(iteli,itelj)
14976           dxj=dc(1,j)
14977           dyj=dc(2,j)
14978           dzj=dc(3,j)
14979           dx_normj=dc_norm(1,j)
14980           dy_normj=dc_norm(2,j)
14981           dz_normj=dc_norm(3,j)
14982 !          xj=c(1,j)+0.5D0*dxj-xmedi
14983 !          yj=c(2,j)+0.5D0*dyj-ymedi
14984 !          zj=c(3,j)+0.5D0*dzj-zmedi
14985           xj=c(1,j)+0.5D0*dxj
14986           yj=c(2,j)+0.5D0*dyj
14987           zj=c(3,j)+0.5D0*dzj
14988           xj=mod(xj,boxxsize)
14989           if (xj.lt.0) xj=xj+boxxsize
14990           yj=mod(yj,boxysize)
14991           if (yj.lt.0) yj=yj+boxysize
14992           zj=mod(zj,boxzsize)
14993           if (zj.lt.0) zj=zj+boxzsize
14994       isubchap=0
14995       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14996       xj_safe=xj
14997       yj_safe=yj
14998       zj_safe=zj
14999       do xshift=-1,1
15000       do yshift=-1,1
15001       do zshift=-1,1
15002           xj=xj_safe+xshift*boxxsize
15003           yj=yj_safe+yshift*boxysize
15004           zj=zj_safe+zshift*boxzsize
15005           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15006           if(dist_temp.lt.dist_init) then
15007             dist_init=dist_temp
15008             xj_temp=xj
15009             yj_temp=yj
15010             zj_temp=zj
15011             isubchap=1
15012           endif
15013        enddo
15014        enddo
15015        enddo
15016        if (isubchap.eq.1) then
15017 !C          print *,i,j
15018           xj=xj_temp-xmedi
15019           yj=yj_temp-ymedi
15020           zj=zj_temp-zmedi
15021        else
15022           xj=xj_safe-xmedi
15023           yj=yj_safe-ymedi
15024           zj=zj_safe-zmedi
15025        endif
15026
15027           rij=xj*xj+yj*yj+zj*zj
15028           rrmij=1.0D0/rij
15029           rij=dsqrt(rij)
15030           sss=sscale(rij/rpp(iteli,itelj))
15031             sss_ele_cut=sscale_ele(rij)
15032             sss_ele_grad=sscagrad_ele(rij)
15033             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15034             if (sss_ele_cut.le.0.0) cycle
15035           if (sss.gt.0.0d0) then
15036             rmij=1.0D0/rij
15037             r3ij=rrmij*rmij
15038             r6ij=r3ij*r3ij
15039             ev1=aaa*r6ij*r6ij
15040 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15041             if (j.eq.i+2) ev1=scal_el*ev1
15042             ev2=bbb*r6ij
15043             evdwij=ev1+ev2
15044             if (energy_dec) then
15045               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15046             endif
15047             evdw1=evdw1+evdwij*sss*sss_ele_cut
15048 !
15049 ! Calculate contributions to the Cartesian gradient.
15050 !
15051             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15052 !            ggg(1)=facvdw*xj
15053 !            ggg(2)=facvdw*yj
15054 !            ggg(3)=facvdw*zj
15055           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15056           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15057           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15058           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15059           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15060           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15061
15062             do k=1,3
15063               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15064               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15065             enddo
15066           endif
15067         enddo ! j
15068       enddo   ! i
15069       return
15070       end subroutine evdwpp_short
15071 !-----------------------------------------------------------------------------
15072       subroutine escp_long(evdw2,evdw2_14)
15073 !
15074 ! This subroutine calculates the excluded-volume interaction energy between
15075 ! peptide-group centers and side chains and its gradient in virtual-bond and
15076 ! side-chain vectors.
15077 !
15078 !      implicit real*8 (a-h,o-z)
15079 !      include 'DIMENSIONS'
15080 !      include 'COMMON.GEO'
15081 !      include 'COMMON.VAR'
15082 !      include 'COMMON.LOCAL'
15083 !      include 'COMMON.CHAIN'
15084 !      include 'COMMON.DERIV'
15085 !      include 'COMMON.INTERACT'
15086 !      include 'COMMON.FFIELD'
15087 !      include 'COMMON.IOUNITS'
15088 !      include 'COMMON.CONTROL'
15089       real(kind=8),dimension(3) :: ggg
15090 !el local variables
15091       integer :: i,iint,j,k,iteli,itypj,subchap
15092       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15093       real(kind=8) :: evdw2,evdw2_14,evdwij
15094       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15095                     dist_temp, dist_init
15096
15097       evdw2=0.0D0
15098       evdw2_14=0.0d0
15099 !d    print '(a)','Enter ESCP'
15100 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15101       do i=iatscp_s,iatscp_e
15102         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15103         iteli=itel(i)
15104         xi=0.5D0*(c(1,i)+c(1,i+1))
15105         yi=0.5D0*(c(2,i)+c(2,i+1))
15106         zi=0.5D0*(c(3,i)+c(3,i+1))
15107           xi=mod(xi,boxxsize)
15108           if (xi.lt.0) xi=xi+boxxsize
15109           yi=mod(yi,boxysize)
15110           if (yi.lt.0) yi=yi+boxysize
15111           zi=mod(zi,boxzsize)
15112           if (zi.lt.0) zi=zi+boxzsize
15113
15114         do iint=1,nscp_gr(i)
15115
15116         do j=iscpstart(i,iint),iscpend(i,iint)
15117           itypj=itype(j,1)
15118           if (itypj.eq.ntyp1) cycle
15119 ! Uncomment following three lines for SC-p interactions
15120 !         xj=c(1,nres+j)-xi
15121 !         yj=c(2,nres+j)-yi
15122 !         zj=c(3,nres+j)-zi
15123 ! Uncomment following three lines for Ca-p interactions
15124           xj=c(1,j)
15125           yj=c(2,j)
15126           zj=c(3,j)
15127           xj=mod(xj,boxxsize)
15128           if (xj.lt.0) xj=xj+boxxsize
15129           yj=mod(yj,boxysize)
15130           if (yj.lt.0) yj=yj+boxysize
15131           zj=mod(zj,boxzsize)
15132           if (zj.lt.0) zj=zj+boxzsize
15133       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15134       xj_safe=xj
15135       yj_safe=yj
15136       zj_safe=zj
15137       subchap=0
15138       do xshift=-1,1
15139       do yshift=-1,1
15140       do zshift=-1,1
15141           xj=xj_safe+xshift*boxxsize
15142           yj=yj_safe+yshift*boxysize
15143           zj=zj_safe+zshift*boxzsize
15144           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15145           if(dist_temp.lt.dist_init) then
15146             dist_init=dist_temp
15147             xj_temp=xj
15148             yj_temp=yj
15149             zj_temp=zj
15150             subchap=1
15151           endif
15152        enddo
15153        enddo
15154        enddo
15155        if (subchap.eq.1) then
15156           xj=xj_temp-xi
15157           yj=yj_temp-yi
15158           zj=zj_temp-zi
15159        else
15160           xj=xj_safe-xi
15161           yj=yj_safe-yi
15162           zj=zj_safe-zi
15163        endif
15164           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15165
15166           rij=dsqrt(1.0d0/rrij)
15167             sss_ele_cut=sscale_ele(rij)
15168             sss_ele_grad=sscagrad_ele(rij)
15169 !            print *,sss_ele_cut,sss_ele_grad,&
15170 !            (rij),r_cut_ele,rlamb_ele
15171             if (sss_ele_cut.le.0.0) cycle
15172           sss=sscale((rij/rscp(itypj,iteli)))
15173           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15174           if (sss.lt.1.0d0) then
15175
15176             fac=rrij**expon2
15177             e1=fac*fac*aad(itypj,iteli)
15178             e2=fac*bad(itypj,iteli)
15179             if (iabs(j-i) .le. 2) then
15180               e1=scal14*e1
15181               e2=scal14*e2
15182               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15183             endif
15184             evdwij=e1+e2
15185             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15186             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15187                 'evdw2',i,j,sss,evdwij
15188 !
15189 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15190 !
15191             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15192             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15193             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15194             ggg(1)=xj*fac
15195             ggg(2)=yj*fac
15196             ggg(3)=zj*fac
15197 ! Uncomment following three lines for SC-p interactions
15198 !           do k=1,3
15199 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15200 !           enddo
15201 ! Uncomment following line for SC-p interactions
15202 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15203             do k=1,3
15204               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15205               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15206             enddo
15207           endif
15208         enddo
15209
15210         enddo ! iint
15211       enddo ! i
15212       do i=1,nct
15213         do j=1,3
15214           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15215           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15216           gradx_scp(j,i)=expon*gradx_scp(j,i)
15217         enddo
15218       enddo
15219 !******************************************************************************
15220 !
15221 !                              N O T E !!!
15222 !
15223 ! To save time the factor EXPON has been extracted from ALL components
15224 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15225 ! use!
15226 !
15227 !******************************************************************************
15228       return
15229       end subroutine escp_long
15230 !-----------------------------------------------------------------------------
15231       subroutine escp_short(evdw2,evdw2_14)
15232 !
15233 ! This subroutine calculates the excluded-volume interaction energy between
15234 ! peptide-group centers and side chains and its gradient in virtual-bond and
15235 ! side-chain vectors.
15236 !
15237 !      implicit real*8 (a-h,o-z)
15238 !      include 'DIMENSIONS'
15239 !      include 'COMMON.GEO'
15240 !      include 'COMMON.VAR'
15241 !      include 'COMMON.LOCAL'
15242 !      include 'COMMON.CHAIN'
15243 !      include 'COMMON.DERIV'
15244 !      include 'COMMON.INTERACT'
15245 !      include 'COMMON.FFIELD'
15246 !      include 'COMMON.IOUNITS'
15247 !      include 'COMMON.CONTROL'
15248       real(kind=8),dimension(3) :: ggg
15249 !el local variables
15250       integer :: i,iint,j,k,iteli,itypj,subchap
15251       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15252       real(kind=8) :: evdw2,evdw2_14,evdwij
15253       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15254                     dist_temp, dist_init
15255
15256       evdw2=0.0D0
15257       evdw2_14=0.0d0
15258 !d    print '(a)','Enter ESCP'
15259 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15260       do i=iatscp_s,iatscp_e
15261         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15262         iteli=itel(i)
15263         xi=0.5D0*(c(1,i)+c(1,i+1))
15264         yi=0.5D0*(c(2,i)+c(2,i+1))
15265         zi=0.5D0*(c(3,i)+c(3,i+1))
15266           xi=mod(xi,boxxsize)
15267           if (xi.lt.0) xi=xi+boxxsize
15268           yi=mod(yi,boxysize)
15269           if (yi.lt.0) yi=yi+boxysize
15270           zi=mod(zi,boxzsize)
15271           if (zi.lt.0) zi=zi+boxzsize
15272
15273         do iint=1,nscp_gr(i)
15274
15275         do j=iscpstart(i,iint),iscpend(i,iint)
15276           itypj=itype(j,1)
15277           if (itypj.eq.ntyp1) cycle
15278 ! Uncomment following three lines for SC-p interactions
15279 !         xj=c(1,nres+j)-xi
15280 !         yj=c(2,nres+j)-yi
15281 !         zj=c(3,nres+j)-zi
15282 ! Uncomment following three lines for Ca-p interactions
15283 !          xj=c(1,j)-xi
15284 !          yj=c(2,j)-yi
15285 !          zj=c(3,j)-zi
15286           xj=c(1,j)
15287           yj=c(2,j)
15288           zj=c(3,j)
15289           xj=mod(xj,boxxsize)
15290           if (xj.lt.0) xj=xj+boxxsize
15291           yj=mod(yj,boxysize)
15292           if (yj.lt.0) yj=yj+boxysize
15293           zj=mod(zj,boxzsize)
15294           if (zj.lt.0) zj=zj+boxzsize
15295       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15296       xj_safe=xj
15297       yj_safe=yj
15298       zj_safe=zj
15299       subchap=0
15300       do xshift=-1,1
15301       do yshift=-1,1
15302       do zshift=-1,1
15303           xj=xj_safe+xshift*boxxsize
15304           yj=yj_safe+yshift*boxysize
15305           zj=zj_safe+zshift*boxzsize
15306           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15307           if(dist_temp.lt.dist_init) then
15308             dist_init=dist_temp
15309             xj_temp=xj
15310             yj_temp=yj
15311             zj_temp=zj
15312             subchap=1
15313           endif
15314        enddo
15315        enddo
15316        enddo
15317        if (subchap.eq.1) then
15318           xj=xj_temp-xi
15319           yj=yj_temp-yi
15320           zj=zj_temp-zi
15321        else
15322           xj=xj_safe-xi
15323           yj=yj_safe-yi
15324           zj=zj_safe-zi
15325        endif
15326
15327           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15328           rij=dsqrt(1.0d0/rrij)
15329             sss_ele_cut=sscale_ele(rij)
15330             sss_ele_grad=sscagrad_ele(rij)
15331 !            print *,sss_ele_cut,sss_ele_grad,&
15332 !            (rij),r_cut_ele,rlamb_ele
15333             if (sss_ele_cut.le.0.0) cycle
15334           sss=sscale(rij/rscp(itypj,iteli))
15335           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15336           if (sss.gt.0.0d0) then
15337
15338             fac=rrij**expon2
15339             e1=fac*fac*aad(itypj,iteli)
15340             e2=fac*bad(itypj,iteli)
15341             if (iabs(j-i) .le. 2) then
15342               e1=scal14*e1
15343               e2=scal14*e2
15344               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15345             endif
15346             evdwij=e1+e2
15347             evdw2=evdw2+evdwij*sss*sss_ele_cut
15348             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15349                 'evdw2',i,j,sss,evdwij
15350 !
15351 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15352 !
15353             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15354             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15355             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15356
15357             ggg(1)=xj*fac
15358             ggg(2)=yj*fac
15359             ggg(3)=zj*fac
15360 ! Uncomment following three lines for SC-p interactions
15361 !           do k=1,3
15362 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15363 !           enddo
15364 ! Uncomment following line for SC-p interactions
15365 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15366             do k=1,3
15367               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15368               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15369             enddo
15370           endif
15371         enddo
15372
15373         enddo ! iint
15374       enddo ! i
15375       do i=1,nct
15376         do j=1,3
15377           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15378           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15379           gradx_scp(j,i)=expon*gradx_scp(j,i)
15380         enddo
15381       enddo
15382 !******************************************************************************
15383 !
15384 !                              N O T E !!!
15385 !
15386 ! To save time the factor EXPON has been extracted from ALL components
15387 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15388 ! use!
15389 !
15390 !******************************************************************************
15391       return
15392       end subroutine escp_short
15393 !-----------------------------------------------------------------------------
15394 ! energy_p_new-sep_barrier.F
15395 !-----------------------------------------------------------------------------
15396       subroutine sc_grad_scale(scalfac)
15397 !      implicit real*8 (a-h,o-z)
15398       use calc_data
15399 !      include 'DIMENSIONS'
15400 !      include 'COMMON.CHAIN'
15401 !      include 'COMMON.DERIV'
15402 !      include 'COMMON.CALC'
15403 !      include 'COMMON.IOUNITS'
15404       real(kind=8),dimension(3) :: dcosom1,dcosom2
15405       real(kind=8) :: scalfac
15406 !el local variables
15407 !      integer :: i,j,k,l
15408
15409       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15410       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15411       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15412            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15413 ! diagnostics only
15414 !      eom1=0.0d0
15415 !      eom2=0.0d0
15416 !      eom12=evdwij*eps1_om12
15417 ! end diagnostics
15418 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15419 !     &  " sigder",sigder
15420 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15421 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15422       do k=1,3
15423         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15424         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15425       enddo
15426       do k=1,3
15427         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15428          *sss_ele_cut
15429       enddo
15430 !      write (iout,*) "gg",(gg(k),k=1,3)
15431       do k=1,3
15432         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15433                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15434                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15435                  *sss_ele_cut
15436         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15437                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15438                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15439          *sss_ele_cut
15440 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15441 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15442 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15443 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15444       enddo
15445 !
15446 ! Calculate the components of the gradient in DC and X
15447 !
15448       do l=1,3
15449         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15450         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15451       enddo
15452       return
15453       end subroutine sc_grad_scale
15454 !-----------------------------------------------------------------------------
15455 ! energy_split-sep.F
15456 !-----------------------------------------------------------------------------
15457       subroutine etotal_long(energia)
15458 !
15459 ! Compute the long-range slow-varying contributions to the energy
15460 !
15461 !      implicit real*8 (a-h,o-z)
15462 !      include 'DIMENSIONS'
15463       use MD_data, only: totT,usampl,eq_time
15464 #ifndef ISNAN
15465       external proc_proc
15466 #ifdef WINPGI
15467 !MS$ATTRIBUTES C ::  proc_proc
15468 #endif
15469 #endif
15470 #ifdef MPI
15471       include "mpif.h"
15472       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15473 #endif
15474 !      include 'COMMON.SETUP'
15475 !      include 'COMMON.IOUNITS'
15476 !      include 'COMMON.FFIELD'
15477 !      include 'COMMON.DERIV'
15478 !      include 'COMMON.INTERACT'
15479 !      include 'COMMON.SBRIDGE'
15480 !      include 'COMMON.CHAIN'
15481 !      include 'COMMON.VAR'
15482 !      include 'COMMON.LOCAL'
15483 !      include 'COMMON.MD'
15484       real(kind=8),dimension(0:n_ene) :: energia
15485 !el local variables
15486       integer :: i,n_corr,n_corr1,ierror,ierr
15487       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15488                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15489                   ecorr,ecorr5,ecorr6,eturn6,time00
15490 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15491 !elwrite(iout,*)"in etotal long"
15492
15493       if (modecalc.eq.12.or.modecalc.eq.14) then
15494 #ifdef MPI
15495 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15496 #else
15497         call int_from_cart1(.false.)
15498 #endif
15499       endif
15500 !elwrite(iout,*)"in etotal long"
15501
15502 #ifdef MPI
15503 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15504 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15505       call flush(iout)
15506       if (nfgtasks.gt.1) then
15507         time00=MPI_Wtime()
15508 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15509         if (fg_rank.eq.0) then
15510           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15511 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15512 !          call flush(iout)
15513 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15514 ! FG slaves as WEIGHTS array.
15515           weights_(1)=wsc
15516           weights_(2)=wscp
15517           weights_(3)=welec
15518           weights_(4)=wcorr
15519           weights_(5)=wcorr5
15520           weights_(6)=wcorr6
15521           weights_(7)=wel_loc
15522           weights_(8)=wturn3
15523           weights_(9)=wturn4
15524           weights_(10)=wturn6
15525           weights_(11)=wang
15526           weights_(12)=wscloc
15527           weights_(13)=wtor
15528           weights_(14)=wtor_d
15529           weights_(15)=wstrain
15530           weights_(16)=wvdwpp
15531           weights_(17)=wbond
15532           weights_(18)=scal14
15533           weights_(21)=wsccor
15534 ! FG Master broadcasts the WEIGHTS_ array
15535           call MPI_Bcast(weights_(1),n_ene,&
15536               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15537         else
15538 ! FG slaves receive the WEIGHTS array
15539           call MPI_Bcast(weights(1),n_ene,&
15540               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15541           wsc=weights(1)
15542           wscp=weights(2)
15543           welec=weights(3)
15544           wcorr=weights(4)
15545           wcorr5=weights(5)
15546           wcorr6=weights(6)
15547           wel_loc=weights(7)
15548           wturn3=weights(8)
15549           wturn4=weights(9)
15550           wturn6=weights(10)
15551           wang=weights(11)
15552           wscloc=weights(12)
15553           wtor=weights(13)
15554           wtor_d=weights(14)
15555           wstrain=weights(15)
15556           wvdwpp=weights(16)
15557           wbond=weights(17)
15558           scal14=weights(18)
15559           wsccor=weights(21)
15560         endif
15561         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15562           king,FG_COMM,IERR)
15563          time_Bcast=time_Bcast+MPI_Wtime()-time00
15564          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15565 !        call chainbuild_cart
15566 !        call int_from_cart1(.false.)
15567       endif
15568 !      write (iout,*) 'Processor',myrank,
15569 !     &  ' calling etotal_short ipot=',ipot
15570 !      call flush(iout)
15571 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15572 #endif
15573 !d    print *,'nnt=',nnt,' nct=',nct
15574 !
15575 !elwrite(iout,*)"in etotal long"
15576 ! Compute the side-chain and electrostatic interaction energy
15577 !
15578       goto (101,102,103,104,105,106) ipot
15579 ! Lennard-Jones potential.
15580   101 call elj_long(evdw)
15581 !d    print '(a)','Exit ELJ'
15582       goto 107
15583 ! Lennard-Jones-Kihara potential (shifted).
15584   102 call eljk_long(evdw)
15585       goto 107
15586 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15587   103 call ebp_long(evdw)
15588       goto 107
15589 ! Gay-Berne potential (shifted LJ, angular dependence).
15590   104 call egb_long(evdw)
15591       goto 107
15592 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15593   105 call egbv_long(evdw)
15594       goto 107
15595 ! Soft-sphere potential
15596   106 call e_softsphere(evdw)
15597 !
15598 ! Calculate electrostatic (H-bonding) energy of the main chain.
15599 !
15600   107 continue
15601       call vec_and_deriv
15602       if (ipot.lt.6) then
15603 #ifdef SPLITELE
15604          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15605              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15606              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15607              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15608 #else
15609          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15610              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15611              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15612              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15613 #endif
15614            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15615          else
15616             ees=0
15617             evdw1=0
15618             eel_loc=0
15619             eello_turn3=0
15620             eello_turn4=0
15621          endif
15622       else
15623 !        write (iout,*) "Soft-spheer ELEC potential"
15624         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15625          eello_turn4)
15626       endif
15627 !
15628 ! Calculate excluded-volume interaction energy between peptide groups
15629 ! and side chains.
15630 !
15631       if (ipot.lt.6) then
15632        if(wscp.gt.0d0) then
15633         call escp_long(evdw2,evdw2_14)
15634        else
15635         evdw2=0
15636         evdw2_14=0
15637        endif
15638       else
15639         call escp_soft_sphere(evdw2,evdw2_14)
15640       endif
15641 !
15642 ! 12/1/95 Multi-body terms
15643 !
15644       n_corr=0
15645       n_corr1=0
15646       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15647           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15648          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15649 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15650 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15651       else
15652          ecorr=0.0d0
15653          ecorr5=0.0d0
15654          ecorr6=0.0d0
15655          eturn6=0.0d0
15656       endif
15657       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15658          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15659       endif
15660 !
15661 ! If performing constraint dynamics, call the constraint energy
15662 !  after the equilibration time
15663       if(usampl.and.totT.gt.eq_time) then
15664          call EconstrQ
15665          call Econstr_back
15666       else
15667          Uconst=0.0d0
15668          Uconst_back=0.0d0
15669       endif
15670 !
15671 ! Sum the energies
15672 !
15673       do i=1,n_ene
15674         energia(i)=0.0d0
15675       enddo
15676       energia(1)=evdw
15677 #ifdef SCP14
15678       energia(2)=evdw2-evdw2_14
15679       energia(18)=evdw2_14
15680 #else
15681       energia(2)=evdw2
15682       energia(18)=0.0d0
15683 #endif
15684 #ifdef SPLITELE
15685       energia(3)=ees
15686       energia(16)=evdw1
15687 #else
15688       energia(3)=ees+evdw1
15689       energia(16)=0.0d0
15690 #endif
15691       energia(4)=ecorr
15692       energia(5)=ecorr5
15693       energia(6)=ecorr6
15694       energia(7)=eel_loc
15695       energia(8)=eello_turn3
15696       energia(9)=eello_turn4
15697       energia(10)=eturn6
15698       energia(20)=Uconst+Uconst_back
15699       call sum_energy(energia,.true.)
15700 !      write (iout,*) "Exit ETOTAL_LONG"
15701       call flush(iout)
15702       return
15703       end subroutine etotal_long
15704 !-----------------------------------------------------------------------------
15705       subroutine etotal_short(energia)
15706 !
15707 ! Compute the short-range fast-varying contributions to the energy
15708 !
15709 !      implicit real*8 (a-h,o-z)
15710 !      include 'DIMENSIONS'
15711 #ifndef ISNAN
15712       external proc_proc
15713 #ifdef WINPGI
15714 !MS$ATTRIBUTES C ::  proc_proc
15715 #endif
15716 #endif
15717 #ifdef MPI
15718       include "mpif.h"
15719       integer :: ierror,ierr
15720       real(kind=8),dimension(n_ene) :: weights_
15721       real(kind=8) :: time00
15722 #endif
15723 !      include 'COMMON.SETUP'
15724 !      include 'COMMON.IOUNITS'
15725 !      include 'COMMON.FFIELD'
15726 !      include 'COMMON.DERIV'
15727 !      include 'COMMON.INTERACT'
15728 !      include 'COMMON.SBRIDGE'
15729 !      include 'COMMON.CHAIN'
15730 !      include 'COMMON.VAR'
15731 !      include 'COMMON.LOCAL'
15732       real(kind=8),dimension(0:n_ene) :: energia
15733 !el local variables
15734       integer :: i,nres6
15735       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15736       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15737       nres6=6*nres
15738
15739 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15740 !      call flush(iout)
15741       if (modecalc.eq.12.or.modecalc.eq.14) then
15742 #ifdef MPI
15743         if (fg_rank.eq.0) call int_from_cart1(.false.)
15744 #else
15745         call int_from_cart1(.false.)
15746 #endif
15747       endif
15748 #ifdef MPI
15749 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15750 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15751 !      call flush(iout)
15752       if (nfgtasks.gt.1) then
15753         time00=MPI_Wtime()
15754 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15755         if (fg_rank.eq.0) then
15756           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15757 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15758 !          call flush(iout)
15759 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15760 ! FG slaves as WEIGHTS array.
15761           weights_(1)=wsc
15762           weights_(2)=wscp
15763           weights_(3)=welec
15764           weights_(4)=wcorr
15765           weights_(5)=wcorr5
15766           weights_(6)=wcorr6
15767           weights_(7)=wel_loc
15768           weights_(8)=wturn3
15769           weights_(9)=wturn4
15770           weights_(10)=wturn6
15771           weights_(11)=wang
15772           weights_(12)=wscloc
15773           weights_(13)=wtor
15774           weights_(14)=wtor_d
15775           weights_(15)=wstrain
15776           weights_(16)=wvdwpp
15777           weights_(17)=wbond
15778           weights_(18)=scal14
15779           weights_(21)=wsccor
15780 ! FG Master broadcasts the WEIGHTS_ array
15781           call MPI_Bcast(weights_(1),n_ene,&
15782               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15783         else
15784 ! FG slaves receive the WEIGHTS array
15785           call MPI_Bcast(weights(1),n_ene,&
15786               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15787           wsc=weights(1)
15788           wscp=weights(2)
15789           welec=weights(3)
15790           wcorr=weights(4)
15791           wcorr5=weights(5)
15792           wcorr6=weights(6)
15793           wel_loc=weights(7)
15794           wturn3=weights(8)
15795           wturn4=weights(9)
15796           wturn6=weights(10)
15797           wang=weights(11)
15798           wscloc=weights(12)
15799           wtor=weights(13)
15800           wtor_d=weights(14)
15801           wstrain=weights(15)
15802           wvdwpp=weights(16)
15803           wbond=weights(17)
15804           scal14=weights(18)
15805           wsccor=weights(21)
15806         endif
15807 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15808         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15809           king,FG_COMM,IERR)
15810 !        write (iout,*) "Processor",myrank," BROADCAST c"
15811         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15812           king,FG_COMM,IERR)
15813 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15814         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15815           king,FG_COMM,IERR)
15816 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15817         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15818           king,FG_COMM,IERR)
15819 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15820         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15821           king,FG_COMM,IERR)
15822 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15823         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15824           king,FG_COMM,IERR)
15825 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15826         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15827           king,FG_COMM,IERR)
15828 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15829         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15830           king,FG_COMM,IERR)
15831 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15832         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15833           king,FG_COMM,IERR)
15834          time_Bcast=time_Bcast+MPI_Wtime()-time00
15835 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15836       endif
15837 !      write (iout,*) 'Processor',myrank,
15838 !     &  ' calling etotal_short ipot=',ipot
15839 !      call flush(iout)
15840 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15841 #endif
15842 !      call int_from_cart1(.false.)
15843 !
15844 ! Compute the side-chain and electrostatic interaction energy
15845 !
15846       goto (101,102,103,104,105,106) ipot
15847 ! Lennard-Jones potential.
15848   101 call elj_short(evdw)
15849 !d    print '(a)','Exit ELJ'
15850       goto 107
15851 ! Lennard-Jones-Kihara potential (shifted).
15852   102 call eljk_short(evdw)
15853       goto 107
15854 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15855   103 call ebp_short(evdw)
15856       goto 107
15857 ! Gay-Berne potential (shifted LJ, angular dependence).
15858   104 call egb_short(evdw)
15859       goto 107
15860 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15861   105 call egbv_short(evdw)
15862       goto 107
15863 ! Soft-sphere potential - already dealt with in the long-range part
15864   106 evdw=0.0d0
15865 !  106 call e_softsphere_short(evdw)
15866 !
15867 ! Calculate electrostatic (H-bonding) energy of the main chain.
15868 !
15869   107 continue
15870 !
15871 ! Calculate the short-range part of Evdwpp
15872 !
15873       call evdwpp_short(evdw1)
15874 !
15875 ! Calculate the short-range part of ESCp
15876 !
15877       if (ipot.lt.6) then
15878         call escp_short(evdw2,evdw2_14)
15879       endif
15880 !
15881 ! Calculate the bond-stretching energy
15882 !
15883       call ebond(estr)
15884 !
15885 ! Calculate the disulfide-bridge and other energy and the contributions
15886 ! from other distance constraints.
15887       call edis(ehpb)
15888 !
15889 ! Calculate the virtual-bond-angle energy.
15890 !
15891       call ebend(ebe,ethetacnstr)
15892 !
15893 ! Calculate the SC local energy.
15894 !
15895       call vec_and_deriv
15896       call esc(escloc)
15897 !
15898 ! Calculate the virtual-bond torsional energy.
15899 !
15900       call etor(etors,edihcnstr)
15901 !
15902 ! 6/23/01 Calculate double-torsional energy
15903 !
15904       call etor_d(etors_d)
15905 !
15906 ! 21/5/07 Calculate local sicdechain correlation energy
15907 !
15908       if (wsccor.gt.0.0d0) then
15909         call eback_sc_corr(esccor)
15910       else
15911         esccor=0.0d0
15912       endif
15913 !
15914 ! Put energy components into an array
15915 !
15916       do i=1,n_ene
15917         energia(i)=0.0d0
15918       enddo
15919       energia(1)=evdw
15920 #ifdef SCP14
15921       energia(2)=evdw2-evdw2_14
15922       energia(18)=evdw2_14
15923 #else
15924       energia(2)=evdw2
15925       energia(18)=0.0d0
15926 #endif
15927 #ifdef SPLITELE
15928       energia(16)=evdw1
15929 #else
15930       energia(3)=evdw1
15931 #endif
15932       energia(11)=ebe
15933       energia(12)=escloc
15934       energia(13)=etors
15935       energia(14)=etors_d
15936       energia(15)=ehpb
15937       energia(17)=estr
15938       energia(19)=edihcnstr
15939       energia(21)=esccor
15940 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15941       call flush(iout)
15942       call sum_energy(energia,.true.)
15943 !      write (iout,*) "Exit ETOTAL_SHORT"
15944       call flush(iout)
15945       return
15946       end subroutine etotal_short
15947 !-----------------------------------------------------------------------------
15948 ! gnmr1.f
15949 !-----------------------------------------------------------------------------
15950       real(kind=8) function gnmr1(y,ymin,ymax)
15951 !      implicit none
15952       real(kind=8) :: y,ymin,ymax
15953       real(kind=8) :: wykl=4.0d0
15954       if (y.lt.ymin) then
15955         gnmr1=(ymin-y)**wykl/wykl
15956       else if (y.gt.ymax) then
15957         gnmr1=(y-ymax)**wykl/wykl
15958       else
15959         gnmr1=0.0d0
15960       endif
15961       return
15962       end function gnmr1
15963 !-----------------------------------------------------------------------------
15964       real(kind=8) function gnmr1prim(y,ymin,ymax)
15965 !      implicit none
15966       real(kind=8) :: y,ymin,ymax
15967       real(kind=8) :: wykl=4.0d0
15968       if (y.lt.ymin) then
15969         gnmr1prim=-(ymin-y)**(wykl-1)
15970       else if (y.gt.ymax) then
15971         gnmr1prim=(y-ymax)**(wykl-1)
15972       else
15973         gnmr1prim=0.0d0
15974       endif
15975       return
15976       end function gnmr1prim
15977 !----------------------------------------------------------------------------
15978       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15979       real(kind=8) y,ymin,ymax,sigma
15980       real(kind=8) wykl /4.0d0/
15981       if (y.lt.ymin) then
15982         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
15983       else if (y.gt.ymax) then
15984         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
15985       else
15986         rlornmr1=0.0d0
15987       endif
15988       return
15989       end function rlornmr1
15990 !------------------------------------------------------------------------------
15991       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
15992       real(kind=8) y,ymin,ymax,sigma
15993       real(kind=8) wykl /4.0d0/
15994       if (y.lt.ymin) then
15995         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
15996         ((ymin-y)**wykl+sigma**wykl)**2
15997       else if (y.gt.ymax) then
15998         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
15999         ((y-ymax)**wykl+sigma**wykl)**2
16000       else
16001         rlornmr1prim=0.0d0
16002       endif
16003       return
16004       end function rlornmr1prim
16005
16006       real(kind=8) function harmonic(y,ymax)
16007 !      implicit none
16008       real(kind=8) :: y,ymax
16009       real(kind=8) :: wykl=2.0d0
16010       harmonic=(y-ymax)**wykl
16011       return
16012       end function harmonic
16013 !-----------------------------------------------------------------------------
16014       real(kind=8) function harmonicprim(y,ymax)
16015       real(kind=8) :: y,ymin,ymax
16016       real(kind=8) :: wykl=2.0d0
16017       harmonicprim=(y-ymax)*wykl
16018       return
16019       end function harmonicprim
16020 !-----------------------------------------------------------------------------
16021 ! gradient_p.F
16022 !-----------------------------------------------------------------------------
16023       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16024
16025       use io_base, only:intout,briefout
16026 !      implicit real*8 (a-h,o-z)
16027 !      include 'DIMENSIONS'
16028 !      include 'COMMON.CHAIN'
16029 !      include 'COMMON.DERIV'
16030 !      include 'COMMON.VAR'
16031 !      include 'COMMON.INTERACT'
16032 !      include 'COMMON.FFIELD'
16033 !      include 'COMMON.MD'
16034 !      include 'COMMON.IOUNITS'
16035       real(kind=8),external :: ufparm
16036       integer :: uiparm(1)
16037       real(kind=8) :: urparm(1)
16038       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16039       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16040       integer :: n,nf,ind,ind1,i,k,j
16041 !
16042 ! This subroutine calculates total internal coordinate gradient.
16043 ! Depending on the number of function evaluations, either whole energy
16044 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16045 ! internal coordinates are reevaluated or only the cartesian-in-internal
16046 ! coordinate derivatives are evaluated. The subroutine was designed to work
16047 ! with SUMSL.
16048 !
16049 !
16050       icg=mod(nf,2)+1
16051
16052 !d      print *,'grad',nf,icg
16053       if (nf-nfl+1) 20,30,40
16054    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16055 !    write (iout,*) 'grad 20'
16056       if (nf.eq.0) return
16057       goto 40
16058    30 call var_to_geom(n,x)
16059       call chainbuild
16060 !    write (iout,*) 'grad 30'
16061 !
16062 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16063 !
16064    40 call cartder
16065 !     write (iout,*) 'grad 40'
16066 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16067 !
16068 ! Convert the Cartesian gradient into internal-coordinate gradient.
16069 !
16070       ind=0
16071       ind1=0
16072       do i=1,nres-2
16073       gthetai=0.0D0
16074       gphii=0.0D0
16075       do j=i+1,nres-1
16076           ind=ind+1
16077 !         ind=indmat(i,j)
16078 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16079         do k=1,3
16080             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16081           enddo
16082         do k=1,3
16083           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16084           enddo
16085         enddo
16086       do j=i+1,nres-1
16087           ind1=ind1+1
16088 !         ind1=indmat(i,j)
16089 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16090         do k=1,3
16091           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16092           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16093           enddo
16094         enddo
16095       if (i.gt.1) g(i-1)=gphii
16096       if (n.gt.nphi) g(nphi+i)=gthetai
16097       enddo
16098       if (n.le.nphi+ntheta) goto 10
16099       do i=2,nres-1
16100       if (itype(i,1).ne.10) then
16101           galphai=0.0D0
16102         gomegai=0.0D0
16103         do k=1,3
16104           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16105           enddo
16106         do k=1,3
16107           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16108           enddo
16109           g(ialph(i,1))=galphai
16110         g(ialph(i,1)+nside)=gomegai
16111         endif
16112       enddo
16113 !
16114 ! Add the components corresponding to local energy terms.
16115 !
16116    10 continue
16117       do i=1,nvar
16118 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16119         g(i)=g(i)+gloc(i,icg)
16120       enddo
16121 ! Uncomment following three lines for diagnostics.
16122 !d    call intout
16123 !elwrite(iout,*) "in gradient after calling intout"
16124 !d    call briefout(0,0.0d0)
16125 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16126       return
16127       end subroutine gradient
16128 !-----------------------------------------------------------------------------
16129       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16130
16131       use comm_chu
16132 !      implicit real*8 (a-h,o-z)
16133 !      include 'DIMENSIONS'
16134 !      include 'COMMON.DERIV'
16135 !      include 'COMMON.IOUNITS'
16136 !      include 'COMMON.GEO'
16137       integer :: n,nf
16138 !el      integer :: jjj
16139 !el      common /chuju/ jjj
16140       real(kind=8) :: energia(0:n_ene)
16141       integer :: uiparm(1)
16142       real(kind=8) :: urparm(1)
16143       real(kind=8) :: f
16144       real(kind=8),external :: ufparm
16145       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16146 !     if (jjj.gt.0) then
16147 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16148 !     endif
16149       nfl=nf
16150       icg=mod(nf,2)+1
16151 !d      print *,'func',nf,nfl,icg
16152       call var_to_geom(n,x)
16153       call zerograd
16154       call chainbuild
16155 !d    write (iout,*) 'ETOTAL called from FUNC'
16156       call etotal(energia)
16157       call sum_gradient
16158       f=energia(0)
16159 !     if (jjj.gt.0) then
16160 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16161 !       write (iout,*) 'f=',etot
16162 !       jjj=0
16163 !     endif
16164       return
16165       end subroutine func
16166 !-----------------------------------------------------------------------------
16167       subroutine cartgrad
16168 !      implicit real*8 (a-h,o-z)
16169 !      include 'DIMENSIONS'
16170       use energy_data
16171       use MD_data, only: totT,usampl,eq_time
16172 #ifdef MPI
16173       include 'mpif.h'
16174 #endif
16175 !      include 'COMMON.CHAIN'
16176 !      include 'COMMON.DERIV'
16177 !      include 'COMMON.VAR'
16178 !      include 'COMMON.INTERACT'
16179 !      include 'COMMON.FFIELD'
16180 !      include 'COMMON.MD'
16181 !      include 'COMMON.IOUNITS'
16182 !      include 'COMMON.TIME1'
16183 !
16184       integer :: i,j
16185
16186 ! This subrouting calculates total Cartesian coordinate gradient.
16187 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16188 !
16189 #define DEBUG
16190 #ifdef TIMING
16191       time00=MPI_Wtime()
16192 #endif
16193       icg=1
16194       call sum_gradient
16195 #ifdef TIMING
16196 #endif
16197 !el      write (iout,*) "After sum_gradient"
16198 #ifdef DEBUG
16199 !el      write (iout,*) "After sum_gradient"
16200       do i=1,nres-1
16201         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16202         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16203       enddo
16204 #endif
16205 ! If performing constraint dynamics, add the gradients of the constraint energy
16206       if(usampl.and.totT.gt.eq_time) then
16207          do i=1,nct
16208            do j=1,3
16209              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16210              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16211            enddo
16212          enddo
16213          do i=1,nres-3
16214            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16215          enddo
16216          do i=1,nres-2
16217            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16218          enddo
16219       endif
16220 !elwrite (iout,*) "After sum_gradient"
16221 #ifdef TIMING
16222       time01=MPI_Wtime()
16223 #endif
16224       call intcartderiv
16225 !elwrite (iout,*) "After sum_gradient"
16226 #ifdef TIMING
16227       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16228 #endif
16229 !     call checkintcartgrad
16230 !     write(iout,*) 'calling int_to_cart'
16231 #ifdef DEBUG
16232       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16233 #endif
16234       do i=0,nct
16235         do j=1,3
16236           gcart(j,i)=gradc(j,i,icg)
16237           gxcart(j,i)=gradx(j,i,icg)
16238 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16239         enddo
16240 #ifdef DEBUG
16241         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16242           (gxcart(j,i),j=1,3),gloc(i,icg)
16243 #endif
16244       enddo
16245 #ifdef TIMING
16246       time01=MPI_Wtime()
16247 #endif
16248 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16249       call int_to_cart
16250 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16251
16252 #ifdef TIMING
16253             time_inttocart=time_inttocart+MPI_Wtime()-time01
16254 #endif
16255 #ifdef DEBUG
16256             write (iout,*) "gcart and gxcart after int_to_cart"
16257             do i=0,nres-1
16258             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16259                 (gxcart(j,i),j=1,3)
16260             enddo
16261 #endif
16262 #ifdef CARGRAD
16263 #ifdef DEBUG
16264             write (iout,*) "CARGRAD"
16265 #endif
16266             do i=nres,0,-1
16267             do j=1,3
16268               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16269       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16270             enddo
16271       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16272       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16273             enddo
16274       ! Correction: dummy residues
16275             if (nnt.gt.1) then
16276               do j=1,3
16277       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16278                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16279               enddo
16280             endif
16281             if (nct.lt.nres) then
16282               do j=1,3
16283       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16284                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16285               enddo
16286             endif
16287 #endif
16288 #ifdef TIMING
16289             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16290 #endif
16291 #undef DEBUG
16292             return
16293             end subroutine cartgrad
16294       !-----------------------------------------------------------------------------
16295             subroutine zerograd
16296       !      implicit real*8 (a-h,o-z)
16297       !      include 'DIMENSIONS'
16298       !      include 'COMMON.DERIV'
16299       !      include 'COMMON.CHAIN'
16300       !      include 'COMMON.VAR'
16301       !      include 'COMMON.MD'
16302       !      include 'COMMON.SCCOR'
16303       !
16304       !el local variables
16305             integer :: i,j,intertyp,k
16306       ! Initialize Cartesian-coordinate gradient
16307       !
16308       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16309       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16310
16311       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16312       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16313       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16314       !      allocate(gradcorr_long(3,nres))
16315       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16316       !      allocate(gcorr6_turn_long(3,nres))
16317       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16318
16319       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16320
16321       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16322       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16323
16324       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16325       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16326
16327       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16328       !      allocate(gscloc(3,nres)) !(3,maxres)
16329       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16330
16331
16332
16333       !      common /deriv_scloc/
16334       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16335       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16336       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16337       !      common /mpgrad/
16338       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16339
16340
16341
16342       !          gradc(j,i,icg)=0.0d0
16343       !          gradx(j,i,icg)=0.0d0
16344
16345       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16346       !elwrite(iout,*) "icg",icg
16347             do i=-1,nres
16348             do j=1,3
16349               gvdwx(j,i)=0.0D0
16350               gradx_scp(j,i)=0.0D0
16351               gvdwc(j,i)=0.0D0
16352               gvdwc_scp(j,i)=0.0D0
16353               gvdwc_scpp(j,i)=0.0d0
16354               gelc(j,i)=0.0D0
16355               gelc_long(j,i)=0.0D0
16356               gradb(j,i)=0.0d0
16357               gradbx(j,i)=0.0d0
16358               gvdwpp(j,i)=0.0d0
16359               gel_loc(j,i)=0.0d0
16360               gel_loc_long(j,i)=0.0d0
16361               ghpbc(j,i)=0.0D0
16362               ghpbx(j,i)=0.0D0
16363               gcorr3_turn(j,i)=0.0d0
16364               gcorr4_turn(j,i)=0.0d0
16365               gradcorr(j,i)=0.0d0
16366               gradcorr_long(j,i)=0.0d0
16367               gradcorr5_long(j,i)=0.0d0
16368               gradcorr6_long(j,i)=0.0d0
16369               gcorr6_turn_long(j,i)=0.0d0
16370               gradcorr5(j,i)=0.0d0
16371               gradcorr6(j,i)=0.0d0
16372               gcorr6_turn(j,i)=0.0d0
16373               gsccorc(j,i)=0.0d0
16374               gsccorx(j,i)=0.0d0
16375               gradc(j,i,icg)=0.0d0
16376               gradx(j,i,icg)=0.0d0
16377               gscloc(j,i)=0.0d0
16378               gsclocx(j,i)=0.0d0
16379               gliptran(j,i)=0.0d0
16380               gliptranx(j,i)=0.0d0
16381               gliptranc(j,i)=0.0d0
16382               gshieldx(j,i)=0.0d0
16383               gshieldc(j,i)=0.0d0
16384               gshieldc_loc(j,i)=0.0d0
16385               gshieldx_ec(j,i)=0.0d0
16386               gshieldc_ec(j,i)=0.0d0
16387               gshieldc_loc_ec(j,i)=0.0d0
16388               gshieldx_t3(j,i)=0.0d0
16389               gshieldc_t3(j,i)=0.0d0
16390               gshieldc_loc_t3(j,i)=0.0d0
16391               gshieldx_t4(j,i)=0.0d0
16392               gshieldc_t4(j,i)=0.0d0
16393               gshieldc_loc_t4(j,i)=0.0d0
16394               gshieldx_ll(j,i)=0.0d0
16395               gshieldc_ll(j,i)=0.0d0
16396               gshieldc_loc_ll(j,i)=0.0d0
16397               gg_tube(j,i)=0.0d0
16398               gg_tube_sc(j,i)=0.0d0
16399               gradafm(j,i)=0.0d0
16400               gradb_nucl(j,i)=0.0d0
16401               gradbx_nucl(j,i)=0.0d0
16402               gvdwpp_nucl(j,i)=0.0d0
16403               gvdwpp(j,i)=0.0d0
16404               gelpp(j,i)=0.0d0
16405               gvdwpsb(j,i)=0.0d0
16406               gvdwpsb1(j,i)=0.0d0
16407               gvdwsbc(j,i)=0.0d0
16408               gvdwsbx(j,i)=0.0d0
16409               gelsbc(j,i)=0.0d0
16410               gradcorr_nucl(j,i)=0.0d0
16411               gradcorr3_nucl(j,i)=0.0d0
16412               gradxorr_nucl(j,i)=0.0d0
16413               gradxorr3_nucl(j,i)=0.0d0
16414               gelsbx(j,i)=0.0d0
16415               gsbloc(j,i)=0.0d0
16416               gsblocx(j,i)=0.0d0
16417               gradpepcat(j,i)=0.0d0
16418               gradpepcatx(j,i)=0.0d0
16419               gradcatcat(j,i)=0.0d0
16420               gvdwx_scbase(j,i)=0.0d0
16421               gvdwc_scbase(j,i)=0.0d0
16422               gvdwx_pepbase(j,i)=0.0d0
16423               gvdwc_pepbase(j,i)=0.0d0
16424               gvdwx_scpho(j,i)=0.0d0
16425               gvdwc_scpho(j,i)=0.0d0
16426               gvdwc_peppho(j,i)=0.0d0
16427             enddo
16428              enddo
16429             do i=0,nres
16430             do j=1,3
16431               do intertyp=1,3
16432                gloc_sc(intertyp,i,icg)=0.0d0
16433               enddo
16434             enddo
16435             enddo
16436             do i=1,nres
16437              do j=1,maxcontsshi
16438              shield_list(j,i)=0
16439             do k=1,3
16440       !C           print *,i,j,k
16441                grad_shield_side(k,j,i)=0.0d0
16442                grad_shield_loc(k,j,i)=0.0d0
16443              enddo
16444              enddo
16445              ishield_list(i)=0
16446             enddo
16447
16448       !
16449       ! Initialize the gradient of local energy terms.
16450       !
16451       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16452       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16453       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16454       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16455       !      allocate(gel_loc_turn3(nres))
16456       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16457       !      allocate(gsccor_loc(nres))      !(maxres)
16458
16459             do i=1,4*nres
16460             gloc(i,icg)=0.0D0
16461             enddo
16462             do i=1,nres
16463             gel_loc_loc(i)=0.0d0
16464             gcorr_loc(i)=0.0d0
16465             g_corr5_loc(i)=0.0d0
16466             g_corr6_loc(i)=0.0d0
16467             gel_loc_turn3(i)=0.0d0
16468             gel_loc_turn4(i)=0.0d0
16469             gel_loc_turn6(i)=0.0d0
16470             gsccor_loc(i)=0.0d0
16471             enddo
16472       ! initialize gcart and gxcart
16473       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16474             do i=0,nres
16475             do j=1,3
16476               gcart(j,i)=0.0d0
16477               gxcart(j,i)=0.0d0
16478             enddo
16479             enddo
16480             return
16481             end subroutine zerograd
16482       !-----------------------------------------------------------------------------
16483             real(kind=8) function fdum()
16484             fdum=0.0D0
16485             return
16486             end function fdum
16487       !-----------------------------------------------------------------------------
16488       ! intcartderiv.F
16489       !-----------------------------------------------------------------------------
16490             subroutine intcartderiv
16491       !      implicit real*8 (a-h,o-z)
16492       !      include 'DIMENSIONS'
16493 #ifdef MPI
16494             include 'mpif.h'
16495 #endif
16496       !      include 'COMMON.SETUP'
16497       !      include 'COMMON.CHAIN'
16498       !      include 'COMMON.VAR'
16499       !      include 'COMMON.GEO'
16500       !      include 'COMMON.INTERACT'
16501       !      include 'COMMON.DERIV'
16502       !      include 'COMMON.IOUNITS'
16503       !      include 'COMMON.LOCAL'
16504       !      include 'COMMON.SCCOR'
16505             real(kind=8) :: pi4,pi34
16506             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16507             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16508                       dcosomega,dsinomega !(3,3,maxres)
16509             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16510
16511             integer :: i,j,k
16512             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16513                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16514                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16515                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16516             integer :: nres2
16517             nres2=2*nres
16518
16519       !el from module energy-------------
16520       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16521       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16522       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16523
16524       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16525       !el      allocate(dsintau(3,3,3,0:nres2))
16526       !el      allocate(dtauangle(3,3,3,0:nres2))
16527       !el      allocate(domicron(3,2,2,0:nres2))
16528       !el      allocate(dcosomicron(3,2,2,0:nres2))
16529
16530
16531
16532 #if defined(MPI) && defined(PARINTDER)
16533             if (nfgtasks.gt.1 .and. me.eq.king) &
16534             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16535 #endif
16536             pi4 = 0.5d0*pipol
16537             pi34 = 3*pi4
16538
16539       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16540       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16541
16542       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16543             do i=1,nres
16544             do j=1,3
16545               dtheta(j,1,i)=0.0d0
16546               dtheta(j,2,i)=0.0d0
16547               dphi(j,1,i)=0.0d0
16548               dphi(j,2,i)=0.0d0
16549               dphi(j,3,i)=0.0d0
16550             enddo
16551             enddo
16552       ! Derivatives of theta's
16553 #if defined(MPI) && defined(PARINTDER)
16554       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16555             do i=max0(ithet_start-1,3),ithet_end
16556 #else
16557             do i=3,nres
16558 #endif
16559             cost=dcos(theta(i))
16560             sint=sqrt(1-cost*cost)
16561             do j=1,3
16562               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16563               vbld(i-1)
16564               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16565               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16566               vbld(i)
16567               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16568             enddo
16569             enddo
16570 #if defined(MPI) && defined(PARINTDER)
16571       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16572             do i=max0(ithet_start-1,3),ithet_end
16573 #else
16574             do i=3,nres
16575 #endif
16576             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16577             cost1=dcos(omicron(1,i))
16578             sint1=sqrt(1-cost1*cost1)
16579             cost2=dcos(omicron(2,i))
16580             sint2=sqrt(1-cost2*cost2)
16581              do j=1,3
16582       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16583               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16584               cost1*dc_norm(j,i-2))/ &
16585               vbld(i-1)
16586               domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16587               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16588               +cost1*(dc_norm(j,i-1+nres)))/ &
16589               vbld(i-1+nres)
16590               domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16591       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16592       !C Looks messy but better than if in loop
16593               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16594               +cost2*dc_norm(j,i-1))/ &
16595               vbld(i)
16596               domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16597               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16598                +cost2*(-dc_norm(j,i-1+nres)))/ &
16599               vbld(i-1+nres)
16600       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16601               domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16602             enddo
16603              endif
16604             enddo
16605       !elwrite(iout,*) "after vbld write"
16606       ! Derivatives of phi:
16607       ! If phi is 0 or 180 degrees, then the formulas
16608       ! have to be derived by power series expansion of the
16609       ! conventional formulas around 0 and 180.
16610 #ifdef PARINTDER
16611             do i=iphi1_start,iphi1_end
16612 #else
16613             do i=4,nres
16614 #endif
16615       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16616       ! the conventional case
16617             sint=dsin(theta(i))
16618             sint1=dsin(theta(i-1))
16619             sing=dsin(phi(i))
16620             cost=dcos(theta(i))
16621             cost1=dcos(theta(i-1))
16622             cosg=dcos(phi(i))
16623             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16624             fac0=1.0d0/(sint1*sint)
16625             fac1=cost*fac0
16626             fac2=cost1*fac0
16627             fac3=cosg*cost1/(sint1*sint1)
16628             fac4=cosg*cost/(sint*sint)
16629       !    Obtaining the gamma derivatives from sine derivative
16630              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16631                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16632                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16633              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16634              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16635              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16636              do j=1,3
16637                 ctgt=cost/sint
16638                 ctgt1=cost1/sint1
16639                 cosg_inv=1.0d0/cosg
16640                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16641                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16642                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16643                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16644                 dsinphi(j,2,i)= &
16645                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16646                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16647                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16648                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16649                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16650       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16651                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16652                 endif
16653       ! Bug fixed 3/24/05 (AL)
16654              enddo
16655       !   Obtaining the gamma derivatives from cosine derivative
16656             else
16657                do j=1,3
16658                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16659                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16660                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16661                dc_norm(j,i-3))/vbld(i-2)
16662                dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16663                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16664                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16665                dcostheta(j,1,i)
16666                dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16667                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16668                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16669                dc_norm(j,i-1))/vbld(i)
16670                dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16671                endif
16672              enddo
16673             endif
16674             enddo
16675       !alculate derivative of Tauangle
16676 #ifdef PARINTDER
16677             do i=itau_start,itau_end
16678 #else
16679             do i=3,nres
16680       !elwrite(iout,*) " vecpr",i,nres
16681 #endif
16682              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16683       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16684       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16685       !c dtauangle(j,intertyp,dervityp,residue number)
16686       !c INTERTYP=1 SC...Ca...Ca..Ca
16687       ! the conventional case
16688             sint=dsin(theta(i))
16689             sint1=dsin(omicron(2,i-1))
16690             sing=dsin(tauangle(1,i))
16691             cost=dcos(theta(i))
16692             cost1=dcos(omicron(2,i-1))
16693             cosg=dcos(tauangle(1,i))
16694       !elwrite(iout,*) " vecpr5",i,nres
16695             do j=1,3
16696       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16697       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16698             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16699       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16700             enddo
16701             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16702             fac0=1.0d0/(sint1*sint)
16703             fac1=cost*fac0
16704             fac2=cost1*fac0
16705             fac3=cosg*cost1/(sint1*sint1)
16706             fac4=cosg*cost/(sint*sint)
16707       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16708       !    Obtaining the gamma derivatives from sine derivative
16709              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16710                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16711                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16712              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16713              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16714              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16715             do j=1,3
16716                 ctgt=cost/sint
16717                 ctgt1=cost1/sint1
16718                 cosg_inv=1.0d0/cosg
16719                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16720              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16721              *vbld_inv(i-2+nres)
16722                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16723                 dsintau(j,1,2,i)= &
16724                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16725                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16726       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16727                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16728       ! Bug fixed 3/24/05 (AL)
16729                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16730                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16731       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16732                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16733              enddo
16734       !   Obtaining the gamma derivatives from cosine derivative
16735             else
16736                do j=1,3
16737                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16738                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16739                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16740                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16741                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16742                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16743                dcostheta(j,1,i)
16744                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16745                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16746                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16747                dc_norm(j,i-1))/vbld(i)
16748                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16749       !         write (iout,*) "else",i
16750              enddo
16751             endif
16752       !        do k=1,3
16753       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16754       !        enddo
16755             enddo
16756       !C Second case Ca...Ca...Ca...SC
16757 #ifdef PARINTDER
16758             do i=itau_start,itau_end
16759 #else
16760             do i=4,nres
16761 #endif
16762              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16763               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16764       ! the conventional case
16765             sint=dsin(omicron(1,i))
16766             sint1=dsin(theta(i-1))
16767             sing=dsin(tauangle(2,i))
16768             cost=dcos(omicron(1,i))
16769             cost1=dcos(theta(i-1))
16770             cosg=dcos(tauangle(2,i))
16771       !        do j=1,3
16772       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16773       !        enddo
16774             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16775             fac0=1.0d0/(sint1*sint)
16776             fac1=cost*fac0
16777             fac2=cost1*fac0
16778             fac3=cosg*cost1/(sint1*sint1)
16779             fac4=cosg*cost/(sint*sint)
16780       !    Obtaining the gamma derivatives from sine derivative
16781              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16782                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16783                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16784              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16785              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16786              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16787             do j=1,3
16788                 ctgt=cost/sint
16789                 ctgt1=cost1/sint1
16790                 cosg_inv=1.0d0/cosg
16791                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16792                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16793       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16794       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16795                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16796                 dsintau(j,2,2,i)= &
16797                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16798                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16799       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16800       !     & sing*ctgt*domicron(j,1,2,i),
16801       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16802                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16803       ! Bug fixed 3/24/05 (AL)
16804                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16805                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16806       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16807                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16808              enddo
16809       !   Obtaining the gamma derivatives from cosine derivative
16810             else
16811                do j=1,3
16812                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16813                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16814                dc_norm(j,i-3))/vbld(i-2)
16815                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16816                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16817                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16818                dcosomicron(j,1,1,i)
16819                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16820                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16821                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16822                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16823                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16824       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16825              enddo
16826             endif
16827             enddo
16828
16829       !CC third case SC...Ca...Ca...SC
16830 #ifdef PARINTDER
16831
16832             do i=itau_start,itau_end
16833 #else
16834             do i=3,nres
16835 #endif
16836       ! the conventional case
16837             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16838             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16839             sint=dsin(omicron(1,i))
16840             sint1=dsin(omicron(2,i-1))
16841             sing=dsin(tauangle(3,i))
16842             cost=dcos(omicron(1,i))
16843             cost1=dcos(omicron(2,i-1))
16844             cosg=dcos(tauangle(3,i))
16845             do j=1,3
16846             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16847       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16848             enddo
16849             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16850             fac0=1.0d0/(sint1*sint)
16851             fac1=cost*fac0
16852             fac2=cost1*fac0
16853             fac3=cosg*cost1/(sint1*sint1)
16854             fac4=cosg*cost/(sint*sint)
16855       !    Obtaining the gamma derivatives from sine derivative
16856              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16857                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16858                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16859              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16860              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16861              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16862             do j=1,3
16863                 ctgt=cost/sint
16864                 ctgt1=cost1/sint1
16865                 cosg_inv=1.0d0/cosg
16866                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16867                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16868                   *vbld_inv(i-2+nres)
16869                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16870                 dsintau(j,3,2,i)= &
16871                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16872                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16873                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16874       ! Bug fixed 3/24/05 (AL)
16875                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16876                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16877                   *vbld_inv(i-1+nres)
16878       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16879                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16880              enddo
16881       !   Obtaining the gamma derivatives from cosine derivative
16882             else
16883                do j=1,3
16884                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16885                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16886                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16887                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16888                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16889                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16890                dcosomicron(j,1,1,i)
16891                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16892                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16893                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16894                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16895                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16896       !          write(iout,*) "else",i
16897              enddo
16898             endif
16899             enddo
16900
16901 #ifdef CRYST_SC
16902       !   Derivatives of side-chain angles alpha and omega
16903 #if defined(MPI) && defined(PARINTDER)
16904             do i=ibond_start,ibond_end
16905 #else
16906             do i=2,nres-1
16907 #endif
16908               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16909                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16910                  fac6=fac5/vbld(i)
16911                  fac7=fac5*fac5
16912                  fac8=fac5/vbld(i+1)
16913                  fac9=fac5/vbld(i+nres)
16914                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16915                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16916                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16917                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16918                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16919                  sina=sqrt(1-cosa*cosa)
16920                  sino=dsin(omeg(i))
16921       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16922                  do j=1,3
16923                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16924                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16925                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16926                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16927                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16928                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16929                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16930                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16931                   vbld(i+nres))
16932                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16933                 enddo
16934       ! obtaining the derivatives of omega from sines
16935                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16936                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16937                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16938                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16939                    dsin(theta(i+1)))
16940                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16941                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16942                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16943                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16944                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16945                    coso_inv=1.0d0/dcos(omeg(i))
16946                    do j=1,3
16947                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16948                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16949                    (sino*dc_norm(j,i-1))/vbld(i)
16950                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16951                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16952                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16953                    -sino*dc_norm(j,i)/vbld(i+1)
16954                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16955                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16956                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16957                    vbld(i+nres)
16958                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16959                   enddo
16960                else
16961       !   obtaining the derivatives of omega from cosines
16962                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16963                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16964                  fac12=fac10*sina
16965                  fac13=fac12*fac12
16966                  fac14=sina*sina
16967                  do j=1,3
16968                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16969                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16970                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16971                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16972                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16973                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16974                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16975                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16976                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16977                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16978                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16979                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16980                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16981                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16982                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
16983                 enddo
16984               endif
16985              else
16986                do j=1,3
16987                  do k=1,3
16988                    dalpha(k,j,i)=0.0d0
16989                    domega(k,j,i)=0.0d0
16990                  enddo
16991                enddo
16992              endif
16993              enddo
16994 #endif
16995 #if defined(MPI) && defined(PARINTDER)
16996             if (nfgtasks.gt.1) then
16997 #ifdef DEBUG
16998       !d      write (iout,*) "Gather dtheta"
16999       !d      call flush(iout)
17000             write (iout,*) "dtheta before gather"
17001             do i=1,nres
17002             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17003             enddo
17004 #endif
17005             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17006             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17007             king,FG_COMM,IERROR)
17008 #ifdef DEBUG
17009       !d      write (iout,*) "Gather dphi"
17010       !d      call flush(iout)
17011             write (iout,*) "dphi before gather"
17012             do i=1,nres
17013             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17014             enddo
17015 #endif
17016             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17017             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17018             king,FG_COMM,IERROR)
17019       !d      write (iout,*) "Gather dalpha"
17020       !d      call flush(iout)
17021 #ifdef CRYST_SC
17022             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17023             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17024             king,FG_COMM,IERROR)
17025       !d      write (iout,*) "Gather domega"
17026       !d      call flush(iout)
17027             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17028             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17029             king,FG_COMM,IERROR)
17030 #endif
17031             endif
17032 #endif
17033 #ifdef DEBUG
17034             write (iout,*) "dtheta after gather"
17035             do i=1,nres
17036             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17037             enddo
17038             write (iout,*) "dphi after gather"
17039             do i=1,nres
17040             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17041             enddo
17042             write (iout,*) "dalpha after gather"
17043             do i=1,nres
17044             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17045             enddo
17046             write (iout,*) "domega after gather"
17047             do i=1,nres
17048             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17049             enddo
17050 #endif
17051             return
17052             end subroutine intcartderiv
17053       !-----------------------------------------------------------------------------
17054             subroutine checkintcartgrad
17055       !      implicit real*8 (a-h,o-z)
17056       !      include 'DIMENSIONS'
17057 #ifdef MPI
17058             include 'mpif.h'
17059 #endif
17060       !      include 'COMMON.CHAIN'
17061       !      include 'COMMON.VAR'
17062       !      include 'COMMON.GEO'
17063       !      include 'COMMON.INTERACT'
17064       !      include 'COMMON.DERIV'
17065       !      include 'COMMON.IOUNITS'
17066       !      include 'COMMON.SETUP'
17067             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17068             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17069             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17070             real(kind=8),dimension(3) :: dc_norm_s
17071             real(kind=8) :: aincr=1.0d-5
17072             integer :: i,j
17073             real(kind=8) :: dcji
17074             do i=1,nres
17075             phi_s(i)=phi(i)
17076             theta_s(i)=theta(i)
17077             alph_s(i)=alph(i)
17078             omeg_s(i)=omeg(i)
17079             enddo
17080       ! Check theta gradient
17081             write (iout,*) &
17082              "Analytical (upper) and numerical (lower) gradient of theta"
17083             write (iout,*)
17084             do i=3,nres
17085             do j=1,3
17086               dcji=dc(j,i-2)
17087               dc(j,i-2)=dcji+aincr
17088               call chainbuild_cart
17089               call int_from_cart1(.false.)
17090           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17091           dc(j,i-2)=dcji
17092           dcji=dc(j,i-1)
17093           dc(j,i-1)=dc(j,i-1)+aincr
17094           call chainbuild_cart
17095           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17096           dc(j,i-1)=dcji
17097         enddo
17098 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17099 !el          (dtheta(j,2,i),j=1,3)
17100 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17101 !el          (dthetanum(j,2,i),j=1,3)
17102 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17103 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17104 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17105 !el        write (iout,*)
17106       enddo
17107 ! Check gamma gradient
17108       write (iout,*) &
17109        "Analytical (upper) and numerical (lower) gradient of gamma"
17110       do i=4,nres
17111         do j=1,3
17112           dcji=dc(j,i-3)
17113           dc(j,i-3)=dcji+aincr
17114           call chainbuild_cart
17115           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17116               dc(j,i-3)=dcji
17117           dcji=dc(j,i-2)
17118           dc(j,i-2)=dcji+aincr
17119           call chainbuild_cart
17120           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17121           dc(j,i-2)=dcji
17122           dcji=dc(j,i-1)
17123           dc(j,i-1)=dc(j,i-1)+aincr
17124           call chainbuild_cart
17125           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17126           dc(j,i-1)=dcji
17127         enddo
17128 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17129 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17130 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17131 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17132 !el        write (iout,'(5x,3(3f10.5,5x))') &
17133 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17134 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17135 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17136 !el        write (iout,*)
17137       enddo
17138 ! Check alpha gradient
17139       write (iout,*) &
17140        "Analytical (upper) and numerical (lower) gradient of alpha"
17141       do i=2,nres-1
17142        if(itype(i,1).ne.10) then
17143                  do j=1,3
17144                   dcji=dc(j,i-1)
17145                    dc(j,i-1)=dcji+aincr
17146               call chainbuild_cart
17147               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17148                  /aincr
17149                   dc(j,i-1)=dcji
17150               dcji=dc(j,i)
17151               dc(j,i)=dcji+aincr
17152               call chainbuild_cart
17153               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17154                  /aincr
17155               dc(j,i)=dcji
17156               dcji=dc(j,i+nres)
17157               dc(j,i+nres)=dc(j,i+nres)+aincr
17158               call chainbuild_cart
17159               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17160                  /aincr
17161              dc(j,i+nres)=dcji
17162             enddo
17163           endif
17164 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17165 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17166 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17167 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17168 !el        write (iout,'(5x,3(3f10.5,5x))') &
17169 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17170 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17171 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17172 !el        write (iout,*)
17173       enddo
17174 !     Check omega gradient
17175       write (iout,*) &
17176        "Analytical (upper) and numerical (lower) gradient of omega"
17177       do i=2,nres-1
17178        if(itype(i,1).ne.10) then
17179                  do j=1,3
17180                   dcji=dc(j,i-1)
17181                    dc(j,i-1)=dcji+aincr
17182               call chainbuild_cart
17183               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17184                  /aincr
17185                   dc(j,i-1)=dcji
17186               dcji=dc(j,i)
17187               dc(j,i)=dcji+aincr
17188               call chainbuild_cart
17189               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17190                  /aincr
17191               dc(j,i)=dcji
17192               dcji=dc(j,i+nres)
17193               dc(j,i+nres)=dc(j,i+nres)+aincr
17194               call chainbuild_cart
17195               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17196                  /aincr
17197              dc(j,i+nres)=dcji
17198             enddo
17199           endif
17200 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17201 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17202 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17203 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17204 !el        write (iout,'(5x,3(3f10.5,5x))') &
17205 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17206 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17207 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17208 !el        write (iout,*)
17209       enddo
17210       return
17211       end subroutine checkintcartgrad
17212 !-----------------------------------------------------------------------------
17213 ! q_measure.F
17214 !-----------------------------------------------------------------------------
17215       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17216 !      implicit real*8 (a-h,o-z)
17217 !      include 'DIMENSIONS'
17218 !      include 'COMMON.IOUNITS'
17219 !      include 'COMMON.CHAIN'
17220 !      include 'COMMON.INTERACT'
17221 !      include 'COMMON.VAR'
17222       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17223       integer :: kkk,nsep=3
17224       real(kind=8) :: qm      !dist,
17225       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17226       logical :: lprn=.false.
17227       logical :: flag
17228 !      real(kind=8) :: sigm,x
17229
17230 !el      sigm(x)=0.25d0*x     ! local function
17231       qqmax=1.0d10
17232       do kkk=1,nperm
17233       qq = 0.0d0
17234       nl=0
17235        if(flag) then
17236         do il=seg1+nsep,seg2
17237           do jl=seg1,il-nsep
17238             nl=nl+1
17239             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17240                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17241                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17242             dij=dist(il,jl)
17243             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17244             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17245               nl=nl+1
17246               d0ijCM=dsqrt( &
17247                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17248                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17249                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17250               dijCM=dist(il+nres,jl+nres)
17251               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17252             endif
17253             qq = qq+qqij+qqijCM
17254           enddo
17255         enddo
17256         qq = qq/nl
17257       else
17258       do il=seg1,seg2
17259         if((seg3-il).lt.3) then
17260              secseg=il+3
17261         else
17262              secseg=seg3
17263         endif
17264           do jl=secseg,seg4
17265             nl=nl+1
17266             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17267                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17268                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17269             dij=dist(il,jl)
17270             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17271             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17272               nl=nl+1
17273               d0ijCM=dsqrt( &
17274                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17275                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17276                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17277               dijCM=dist(il+nres,jl+nres)
17278               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17279             endif
17280             qq = qq+qqij+qqijCM
17281           enddo
17282         enddo
17283       qq = qq/nl
17284       endif
17285       if (qqmax.le.qq) qqmax=qq
17286       enddo
17287       qwolynes=1.0d0-qqmax
17288       return
17289       end function qwolynes
17290 !-----------------------------------------------------------------------------
17291       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17292 !      implicit real*8 (a-h,o-z)
17293 !      include 'DIMENSIONS'
17294 !      include 'COMMON.IOUNITS'
17295 !      include 'COMMON.CHAIN'
17296 !      include 'COMMON.INTERACT'
17297 !      include 'COMMON.VAR'
17298 !      include 'COMMON.MD'
17299       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17300       integer :: nsep=3, kkk
17301 !el      real(kind=8) :: dist
17302       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17303       logical :: lprn=.false.
17304       logical :: flag
17305       real(kind=8) :: sim,dd0,fac,ddqij
17306 !el      sigm(x)=0.25d0*x           ! local function
17307       do kkk=1,nperm
17308       do i=0,nres
17309         do j=1,3
17310           dqwol(j,i)=0.0d0
17311           dxqwol(j,i)=0.0d0
17312         enddo
17313       enddo
17314       nl=0
17315        if(flag) then
17316         do il=seg1+nsep,seg2
17317           do jl=seg1,il-nsep
17318             nl=nl+1
17319             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17320                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17321                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17322             dij=dist(il,jl)
17323             sim = 1.0d0/sigm(d0ij)
17324             sim = sim*sim
17325             dd0 = dij-d0ij
17326             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17327           do k=1,3
17328               ddqij = (c(k,il)-c(k,jl))*fac
17329               dqwol(k,il)=dqwol(k,il)+ddqij
17330               dqwol(k,jl)=dqwol(k,jl)-ddqij
17331             enddo
17332
17333             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17334               nl=nl+1
17335               d0ijCM=dsqrt( &
17336                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17337                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17338                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17339               dijCM=dist(il+nres,jl+nres)
17340               sim = 1.0d0/sigm(d0ijCM)
17341               sim = sim*sim
17342               dd0=dijCM-d0ijCM
17343               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17344               do k=1,3
17345                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17346                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17347                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17348               enddo
17349             endif
17350           enddo
17351         enddo
17352        else
17353         do il=seg1,seg2
17354         if((seg3-il).lt.3) then
17355              secseg=il+3
17356         else
17357              secseg=seg3
17358         endif
17359           do jl=secseg,seg4
17360             nl=nl+1
17361             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17362                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17363                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17364             dij=dist(il,jl)
17365             sim = 1.0d0/sigm(d0ij)
17366             sim = sim*sim
17367             dd0 = dij-d0ij
17368             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17369             do k=1,3
17370               ddqij = (c(k,il)-c(k,jl))*fac
17371               dqwol(k,il)=dqwol(k,il)+ddqij
17372               dqwol(k,jl)=dqwol(k,jl)-ddqij
17373             enddo
17374             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17375               nl=nl+1
17376               d0ijCM=dsqrt( &
17377                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17378                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17379                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17380               dijCM=dist(il+nres,jl+nres)
17381               sim = 1.0d0/sigm(d0ijCM)
17382               sim=sim*sim
17383               dd0 = dijCM-d0ijCM
17384               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17385               do k=1,3
17386                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17387                dxqwol(k,il)=dxqwol(k,il)+ddqij
17388                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17389               enddo
17390             endif
17391           enddo
17392         enddo
17393       endif
17394       enddo
17395        do i=0,nres
17396          do j=1,3
17397            dqwol(j,i)=dqwol(j,i)/nl
17398            dxqwol(j,i)=dxqwol(j,i)/nl
17399          enddo
17400        enddo
17401       return
17402       end subroutine qwolynes_prim
17403 !-----------------------------------------------------------------------------
17404       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17405 !      implicit real*8 (a-h,o-z)
17406 !      include 'DIMENSIONS'
17407 !      include 'COMMON.IOUNITS'
17408 !      include 'COMMON.CHAIN'
17409 !      include 'COMMON.INTERACT'
17410 !      include 'COMMON.VAR'
17411       integer :: seg1,seg2,seg3,seg4
17412       logical :: flag
17413       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17414       real(kind=8),dimension(3,0:2*nres) :: cdummy
17415       real(kind=8) :: q1,q2
17416       real(kind=8) :: delta=1.0d-10
17417       integer :: i,j
17418
17419       do i=0,nres
17420         do j=1,3
17421           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17422           cdummy(j,i)=c(j,i)
17423           c(j,i)=c(j,i)+delta
17424           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17425           qwolan(j,i)=(q2-q1)/delta
17426           c(j,i)=cdummy(j,i)
17427         enddo
17428       enddo
17429       do i=0,nres
17430         do j=1,3
17431           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17432           cdummy(j,i+nres)=c(j,i+nres)
17433           c(j,i+nres)=c(j,i+nres)+delta
17434           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17435           qwolxan(j,i)=(q2-q1)/delta
17436           c(j,i+nres)=cdummy(j,i+nres)
17437         enddo
17438       enddo
17439 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17440 !      do i=0,nct
17441 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17442 !      enddo
17443 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17444 !      do i=0,nct
17445 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17446 !      enddo
17447       return
17448       end subroutine qwol_num
17449 !-----------------------------------------------------------------------------
17450       subroutine EconstrQ
17451 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17452 !      implicit real*8 (a-h,o-z)
17453 !      include 'DIMENSIONS'
17454 !      include 'COMMON.CONTROL'
17455 !      include 'COMMON.VAR'
17456 !      include 'COMMON.MD'
17457       use MD_data
17458 !#ifndef LANG0
17459 !      include 'COMMON.LANGEVIN'
17460 !#else
17461 !      include 'COMMON.LANGEVIN.lang0'
17462 !#endif
17463 !      include 'COMMON.CHAIN'
17464 !      include 'COMMON.DERIV'
17465 !      include 'COMMON.GEO'
17466 !      include 'COMMON.LOCAL'
17467 !      include 'COMMON.INTERACT'
17468 !      include 'COMMON.IOUNITS'
17469 !      include 'COMMON.NAMES'
17470 !      include 'COMMON.TIME1'
17471       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17472       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17473                    duconst,duxconst
17474       integer :: kstart,kend,lstart,lend,idummy
17475       real(kind=8) :: delta=1.0d-7
17476       integer :: i,j,k,ii
17477       do i=0,nres
17478          do j=1,3
17479             duconst(j,i)=0.0d0
17480             dudconst(j,i)=0.0d0
17481             duxconst(j,i)=0.0d0
17482             dudxconst(j,i)=0.0d0
17483          enddo
17484       enddo
17485       Uconst=0.0d0
17486       do i=1,nfrag
17487          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17488            idummy,idummy)
17489          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17490 ! Calculating the derivatives of Constraint energy with respect to Q
17491          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17492            qinfrag(i,iset))
17493 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17494 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17495 !         hmnum=(hm2-hm1)/delta
17496 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17497 !     &   qinfrag(i,iset))
17498 !         write(iout,*) "harmonicnum frag", hmnum
17499 ! Calculating the derivatives of Q with respect to cartesian coordinates
17500          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17501           idummy,idummy)
17502 !         write(iout,*) "dqwol "
17503 !         do ii=1,nres
17504 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17505 !         enddo
17506 !         write(iout,*) "dxqwol "
17507 !         do ii=1,nres
17508 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17509 !         enddo
17510 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17511 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17512 !     &  ,idummy,idummy)
17513 !  The gradients of Uconst in Cs
17514          do ii=0,nres
17515             do j=1,3
17516                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17517                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17518             enddo
17519          enddo
17520       enddo
17521       do i=1,npair
17522          kstart=ifrag(1,ipair(1,i,iset),iset)
17523          kend=ifrag(2,ipair(1,i,iset),iset)
17524          lstart=ifrag(1,ipair(2,i,iset),iset)
17525          lend=ifrag(2,ipair(2,i,iset),iset)
17526          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17527          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17528 !  Calculating dU/dQ
17529          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17530 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17531 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17532 !         hmnum=(hm2-hm1)/delta
17533 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17534 !     &   qinpair(i,iset))
17535 !         write(iout,*) "harmonicnum pair ", hmnum
17536 ! Calculating dQ/dXi
17537          call qwolynes_prim(kstart,kend,.false.,&
17538           lstart,lend)
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
17548 !        call qwol_num(kstart,kend,.false.
17549 !     &  ,lstart,lend)
17550 ! The gradients of Uconst in Cs
17551          do ii=0,nres
17552             do j=1,3
17553                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17554                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17555             enddo
17556          enddo
17557       enddo
17558 !      write(iout,*) "Uconst inside subroutine ", Uconst
17559 ! Transforming the gradients from Cs to dCs for the backbone
17560       do i=0,nres
17561          do j=i+1,nres
17562            do k=1,3
17563              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17564            enddo
17565          enddo
17566       enddo
17567 !  Transforming the gradients from Cs to dCs for the side chains
17568       do i=1,nres
17569          do j=1,3
17570            dudxconst(j,i)=duxconst(j,i)
17571          enddo
17572       enddo
17573 !      write(iout,*) "dU/ddc backbone "
17574 !       do ii=0,nres
17575 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17576 !      enddo
17577 !      write(iout,*) "dU/ddX side chain "
17578 !      do ii=1,nres
17579 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17580 !      enddo
17581 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17582 !      call dEconstrQ_num
17583       return
17584       end subroutine EconstrQ
17585 !-----------------------------------------------------------------------------
17586       subroutine dEconstrQ_num
17587 ! Calculating numerical dUconst/ddc and dUconst/ddx
17588 !      implicit real*8 (a-h,o-z)
17589 !      include 'DIMENSIONS'
17590 !      include 'COMMON.CONTROL'
17591 !      include 'COMMON.VAR'
17592 !      include 'COMMON.MD'
17593       use MD_data
17594 !#ifndef LANG0
17595 !      include 'COMMON.LANGEVIN'
17596 !#else
17597 !      include 'COMMON.LANGEVIN.lang0'
17598 !#endif
17599 !      include 'COMMON.CHAIN'
17600 !      include 'COMMON.DERIV'
17601 !      include 'COMMON.GEO'
17602 !      include 'COMMON.LOCAL'
17603 !      include 'COMMON.INTERACT'
17604 !      include 'COMMON.IOUNITS'
17605 !      include 'COMMON.NAMES'
17606 !      include 'COMMON.TIME1'
17607       real(kind=8) :: uzap1,uzap2
17608       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17609       integer :: kstart,kend,lstart,lend,idummy
17610       real(kind=8) :: delta=1.0d-7
17611 !el local variables
17612       integer :: i,ii,j
17613 !     real(kind=8) ::
17614 !     For the backbone
17615       do i=0,nres-1
17616          do j=1,3
17617             dUcartan(j,i)=0.0d0
17618             cdummy(j,i)=dc(j,i)
17619             dc(j,i)=dc(j,i)+delta
17620             call chainbuild_cart
17621           uzap2=0.0d0
17622             do ii=1,nfrag
17623              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17624                 idummy,idummy)
17625                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17626                 qinfrag(ii,iset))
17627             enddo
17628             do ii=1,npair
17629                kstart=ifrag(1,ipair(1,ii,iset),iset)
17630                kend=ifrag(2,ipair(1,ii,iset),iset)
17631                lstart=ifrag(1,ipair(2,ii,iset),iset)
17632                lend=ifrag(2,ipair(2,ii,iset),iset)
17633                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17634                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17635                  qinpair(ii,iset))
17636             enddo
17637             dc(j,i)=cdummy(j,i)
17638             call chainbuild_cart
17639             uzap1=0.0d0
17640              do ii=1,nfrag
17641              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17642                 idummy,idummy)
17643                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17644                 qinfrag(ii,iset))
17645             enddo
17646             do ii=1,npair
17647                kstart=ifrag(1,ipair(1,ii,iset),iset)
17648                kend=ifrag(2,ipair(1,ii,iset),iset)
17649                lstart=ifrag(1,ipair(2,ii,iset),iset)
17650                lend=ifrag(2,ipair(2,ii,iset),iset)
17651                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17652                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17653                 qinpair(ii,iset))
17654             enddo
17655             ducartan(j,i)=(uzap2-uzap1)/(delta)
17656          enddo
17657       enddo
17658 ! Calculating numerical gradients for dU/ddx
17659       do i=0,nres-1
17660          duxcartan(j,i)=0.0d0
17661          do j=1,3
17662             cdummy(j,i)=dc(j,i+nres)
17663             dc(j,i+nres)=dc(j,i+nres)+delta
17664             call chainbuild_cart
17665           uzap2=0.0d0
17666             do ii=1,nfrag
17667              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17668                 idummy,idummy)
17669                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17670                 qinfrag(ii,iset))
17671             enddo
17672             do ii=1,npair
17673                kstart=ifrag(1,ipair(1,ii,iset),iset)
17674                kend=ifrag(2,ipair(1,ii,iset),iset)
17675                lstart=ifrag(1,ipair(2,ii,iset),iset)
17676                lend=ifrag(2,ipair(2,ii,iset),iset)
17677                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17678                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17679                 qinpair(ii,iset))
17680             enddo
17681             dc(j,i+nres)=cdummy(j,i)
17682             call chainbuild_cart
17683             uzap1=0.0d0
17684              do ii=1,nfrag
17685                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17686                 ifrag(2,ii,iset),.true.,idummy,idummy)
17687                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17688                 qinfrag(ii,iset))
17689             enddo
17690             do ii=1,npair
17691                kstart=ifrag(1,ipair(1,ii,iset),iset)
17692                kend=ifrag(2,ipair(1,ii,iset),iset)
17693                lstart=ifrag(1,ipair(2,ii,iset),iset)
17694                lend=ifrag(2,ipair(2,ii,iset),iset)
17695                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17696                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17697                 qinpair(ii,iset))
17698             enddo
17699             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17700          enddo
17701       enddo
17702       write(iout,*) "Numerical dUconst/ddc backbone "
17703       do ii=0,nres
17704         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17705       enddo
17706 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17707 !      do ii=1,nres
17708 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17709 !      enddo
17710       return
17711       end subroutine dEconstrQ_num
17712 !-----------------------------------------------------------------------------
17713 ! ssMD.F
17714 !-----------------------------------------------------------------------------
17715       subroutine check_energies
17716
17717 !      use random, only: ran_number
17718
17719 !      implicit none
17720 !     Includes
17721 !      include 'DIMENSIONS'
17722 !      include 'COMMON.CHAIN'
17723 !      include 'COMMON.VAR'
17724 !      include 'COMMON.IOUNITS'
17725 !      include 'COMMON.SBRIDGE'
17726 !      include 'COMMON.LOCAL'
17727 !      include 'COMMON.GEO'
17728
17729 !     External functions
17730 !EL      double precision ran_number
17731 !EL      external ran_number
17732
17733 !     Local variables
17734       integer :: i,j,k,l,lmax,p,pmax
17735       real(kind=8) :: rmin,rmax
17736       real(kind=8) :: eij
17737
17738       real(kind=8) :: d
17739       real(kind=8) :: wi,rij,tj,pj
17740 !      return
17741
17742       i=5
17743       j=14
17744
17745       d=dsc(1)
17746       rmin=2.0D0
17747       rmax=12.0D0
17748
17749       lmax=10000
17750       pmax=1
17751
17752       do k=1,3
17753         c(k,i)=0.0D0
17754         c(k,j)=0.0D0
17755         c(k,nres+i)=0.0D0
17756         c(k,nres+j)=0.0D0
17757       enddo
17758
17759       do l=1,lmax
17760
17761 !t        wi=ran_number(0.0D0,pi)
17762 !        wi=ran_number(0.0D0,pi/6.0D0)
17763 !        wi=0.0D0
17764 !t        tj=ran_number(0.0D0,pi)
17765 !t        pj=ran_number(0.0D0,pi)
17766 !        pj=ran_number(0.0D0,pi/6.0D0)
17767 !        pj=0.0D0
17768
17769         do p=1,pmax
17770 !t           rij=ran_number(rmin,rmax)
17771
17772            c(1,j)=d*sin(pj)*cos(tj)
17773            c(2,j)=d*sin(pj)*sin(tj)
17774            c(3,j)=d*cos(pj)
17775
17776            c(3,nres+i)=-rij
17777
17778            c(1,i)=d*sin(wi)
17779            c(3,i)=-rij-d*cos(wi)
17780
17781            do k=1,3
17782               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17783               dc_norm(k,nres+i)=dc(k,nres+i)/d
17784               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17785               dc_norm(k,nres+j)=dc(k,nres+j)/d
17786            enddo
17787
17788            call dyn_ssbond_ene(i,j,eij)
17789         enddo
17790       enddo
17791       call exit(1)
17792       return
17793       end subroutine check_energies
17794 !-----------------------------------------------------------------------------
17795       subroutine dyn_ssbond_ene(resi,resj,eij)
17796 !      implicit none
17797 !      Includes
17798       use calc_data
17799       use comm_sschecks
17800 !      include 'DIMENSIONS'
17801 !      include 'COMMON.SBRIDGE'
17802 !      include 'COMMON.CHAIN'
17803 !      include 'COMMON.DERIV'
17804 !      include 'COMMON.LOCAL'
17805 !      include 'COMMON.INTERACT'
17806 !      include 'COMMON.VAR'
17807 !      include 'COMMON.IOUNITS'
17808 !      include 'COMMON.CALC'
17809 #ifndef CLUST
17810 #ifndef WHAM
17811        use MD_data
17812 !      include 'COMMON.MD'
17813 !      use MD, only: totT,t_bath
17814 #endif
17815 #endif
17816 !     External functions
17817 !EL      double precision h_base
17818 !EL      external h_base
17819
17820 !     Input arguments
17821       integer :: resi,resj
17822
17823 !     Output arguments
17824       real(kind=8) :: eij
17825
17826 !     Local variables
17827       logical :: havebond
17828       integer itypi,itypj
17829       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17830       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17831       real(kind=8),dimension(3) :: dcosom1,dcosom2
17832       real(kind=8) :: ed
17833       real(kind=8) :: pom1,pom2
17834       real(kind=8) :: ljA,ljB,ljXs
17835       real(kind=8),dimension(1:3) :: d_ljB
17836       real(kind=8) :: ssA,ssB,ssC,ssXs
17837       real(kind=8) :: ssxm,ljxm,ssm,ljm
17838       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17839       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17840       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17841 !-------FIRST METHOD
17842       real(kind=8) :: xm
17843       real(kind=8),dimension(1:3) :: d_xm
17844 !-------END FIRST METHOD
17845 !-------SECOND METHOD
17846 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17847 !-------END SECOND METHOD
17848
17849 !-------TESTING CODE
17850 !el      logical :: checkstop,transgrad
17851 !el      common /sschecks/ checkstop,transgrad
17852
17853       integer :: icheck,nicheck,jcheck,njcheck
17854       real(kind=8),dimension(-1:1) :: echeck
17855       real(kind=8) :: deps,ssx0,ljx0
17856 !-------END TESTING CODE
17857
17858       eij=0.0d0
17859       i=resi
17860       j=resj
17861
17862 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17863 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17864
17865       itypi=itype(i,1)
17866       dxi=dc_norm(1,nres+i)
17867       dyi=dc_norm(2,nres+i)
17868       dzi=dc_norm(3,nres+i)
17869       dsci_inv=vbld_inv(i+nres)
17870
17871       itypj=itype(j,1)
17872       xj=c(1,nres+j)-c(1,nres+i)
17873       yj=c(2,nres+j)-c(2,nres+i)
17874       zj=c(3,nres+j)-c(3,nres+i)
17875       dxj=dc_norm(1,nres+j)
17876       dyj=dc_norm(2,nres+j)
17877       dzj=dc_norm(3,nres+j)
17878       dscj_inv=vbld_inv(j+nres)
17879
17880       chi1=chi(itypi,itypj)
17881       chi2=chi(itypj,itypi)
17882       chi12=chi1*chi2
17883       chip1=chip(itypi)
17884       chip2=chip(itypj)
17885       chip12=chip1*chip2
17886       alf1=alp(itypi)
17887       alf2=alp(itypj)
17888       alf12=0.5D0*(alf1+alf2)
17889
17890       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17891       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17892 !     The following are set in sc_angular
17893 !      erij(1)=xj*rij
17894 !      erij(2)=yj*rij
17895 !      erij(3)=zj*rij
17896 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17897 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17898 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17899       call sc_angular
17900       rij=1.0D0/rij  ! Reset this so it makes sense
17901
17902       sig0ij=sigma(itypi,itypj)
17903       sig=sig0ij*dsqrt(1.0D0/sigsq)
17904
17905       ljXs=sig-sig0ij
17906       ljA=eps1*eps2rt**2*eps3rt**2
17907       ljB=ljA*bb_aq(itypi,itypj)
17908       ljA=ljA*aa_aq(itypi,itypj)
17909       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17910
17911       ssXs=d0cm
17912       deltat1=1.0d0-om1
17913       deltat2=1.0d0+om2
17914       deltat12=om2-om1+2.0d0
17915       cosphi=om12-om1*om2
17916       ssA=akcm
17917       ssB=akct*deltat12
17918       ssC=ss_depth &
17919            +akth*(deltat1*deltat1+deltat2*deltat2) &
17920            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17921       ssxm=ssXs-0.5D0*ssB/ssA
17922
17923 !-------TESTING CODE
17924 !$$$c     Some extra output
17925 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17926 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17927 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17928 !$$$      if (ssx0.gt.0.0d0) then
17929 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17930 !$$$      else
17931 !$$$        ssx0=ssxm
17932 !$$$      endif
17933 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17934 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17935 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17936 !$$$      return
17937 !-------END TESTING CODE
17938
17939 !-------TESTING CODE
17940 !     Stop and plot energy and derivative as a function of distance
17941       if (checkstop) then
17942         ssm=ssC-0.25D0*ssB*ssB/ssA
17943         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17944         if (ssm.lt.ljm .and. &
17945              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17946           nicheck=1000
17947           njcheck=1
17948           deps=0.5d-7
17949         else
17950           checkstop=.false.
17951         endif
17952       endif
17953       if (.not.checkstop) then
17954         nicheck=0
17955         njcheck=-1
17956       endif
17957
17958       do icheck=0,nicheck
17959       do jcheck=-1,njcheck
17960       if (checkstop) rij=(ssxm-1.0d0)+ &
17961              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17962 !-------END TESTING CODE
17963
17964       if (rij.gt.ljxm) then
17965         havebond=.false.
17966         ljd=rij-ljXs
17967         fac=(1.0D0/ljd)**expon
17968         e1=fac*fac*aa_aq(itypi,itypj)
17969         e2=fac*bb_aq(itypi,itypj)
17970         eij=eps1*eps2rt*eps3rt*(e1+e2)
17971         eps2der=eij*eps3rt
17972         eps3der=eij*eps2rt
17973         eij=eij*eps2rt*eps3rt
17974
17975         sigder=-sig/sigsq
17976         e1=e1*eps1*eps2rt**2*eps3rt**2
17977         ed=-expon*(e1+eij)/ljd
17978         sigder=ed*sigder
17979         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17980         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17981         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17982              -2.0D0*alf12*eps3der+sigder*sigsq_om12
17983       else if (rij.lt.ssxm) then
17984         havebond=.true.
17985         ssd=rij-ssXs
17986         eij=ssA*ssd*ssd+ssB*ssd+ssC
17987
17988         ed=2*akcm*ssd+akct*deltat12
17989         pom1=akct*ssd
17990         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
17991         eom1=-2*akth*deltat1-pom1-om2*pom2
17992         eom2= 2*akth*deltat2+pom1-om1*pom2
17993         eom12=pom2
17994       else
17995         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
17996
17997         d_ssxm(1)=0.5D0*akct/ssA
17998         d_ssxm(2)=-d_ssxm(1)
17999         d_ssxm(3)=0.0D0
18000
18001         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18002         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18003         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18004         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18005
18006 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18007         xm=0.5d0*(ssxm+ljxm)
18008         do k=1,3
18009           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18010         enddo
18011         if (rij.lt.xm) then
18012           havebond=.true.
18013           ssm=ssC-0.25D0*ssB*ssB/ssA
18014           d_ssm(1)=0.5D0*akct*ssB/ssA
18015           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18016           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18017           d_ssm(3)=omega
18018           f1=(rij-xm)/(ssxm-xm)
18019           f2=(rij-ssxm)/(xm-ssxm)
18020           h1=h_base(f1,hd1)
18021           h2=h_base(f2,hd2)
18022           eij=ssm*h1+Ht*h2
18023           delta_inv=1.0d0/(xm-ssxm)
18024           deltasq_inv=delta_inv*delta_inv
18025           fac=ssm*hd1-Ht*hd2
18026           fac1=deltasq_inv*fac*(xm-rij)
18027           fac2=deltasq_inv*fac*(rij-ssxm)
18028           ed=delta_inv*(Ht*hd2-ssm*hd1)
18029           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18030           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18031           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18032         else
18033           havebond=.false.
18034           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18035           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18036           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18037           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18038                alf12/eps3rt)
18039           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18040           f1=(rij-ljxm)/(xm-ljxm)
18041           f2=(rij-xm)/(ljxm-xm)
18042           h1=h_base(f1,hd1)
18043           h2=h_base(f2,hd2)
18044           eij=Ht*h1+ljm*h2
18045           delta_inv=1.0d0/(ljxm-xm)
18046           deltasq_inv=delta_inv*delta_inv
18047           fac=Ht*hd1-ljm*hd2
18048           fac1=deltasq_inv*fac*(ljxm-rij)
18049           fac2=deltasq_inv*fac*(rij-xm)
18050           ed=delta_inv*(ljm*hd2-Ht*hd1)
18051           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18052           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18053           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18054         endif
18055 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18056
18057 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18058 !$$$        ssd=rij-ssXs
18059 !$$$        ljd=rij-ljXs
18060 !$$$        fac1=rij-ljxm
18061 !$$$        fac2=rij-ssxm
18062 !$$$
18063 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18064 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18065 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18066 !$$$
18067 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18068 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18069 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18070 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18071 !$$$        d_ssm(3)=omega
18072 !$$$
18073 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18074 !$$$        do k=1,3
18075 !$$$          d_ljm(k)=ljm*d_ljB(k)
18076 !$$$        enddo
18077 !$$$        ljm=ljm*ljB
18078 !$$$
18079 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18080 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18081 !$$$        d_ss(2)=akct*ssd
18082 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18083 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18084 !$$$        d_ss(3)=omega
18085 !$$$
18086 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18087 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18088 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18089 !$$$        do k=1,3
18090 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18091 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18092 !$$$        enddo
18093 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18094 !$$$
18095 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18096 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18097 !$$$        h1=h_base(f1,hd1)
18098 !$$$        h2=h_base(f2,hd2)
18099 !$$$        eij=ss*h1+ljf*h2
18100 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18101 !$$$        deltasq_inv=delta_inv*delta_inv
18102 !$$$        fac=ljf*hd2-ss*hd1
18103 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18104 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18105 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18106 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18107 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18108 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18109 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18110 !$$$
18111 !$$$        havebond=.false.
18112 !$$$        if (ed.gt.0.0d0) havebond=.true.
18113 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18114
18115       endif
18116
18117       if (havebond) then
18118 !#ifndef CLUST
18119 !#ifndef WHAM
18120 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18121 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18122 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18123 !        endif
18124 !#endif
18125 !#endif
18126         dyn_ssbond_ij(i,j)=eij
18127       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18128         dyn_ssbond_ij(i,j)=1.0d300
18129 !#ifndef CLUST
18130 !#ifndef WHAM
18131 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18132 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18133 !#endif
18134 !#endif
18135       endif
18136
18137 !-------TESTING CODE
18138 !el      if (checkstop) then
18139         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18140              "CHECKSTOP",rij,eij,ed
18141         echeck(jcheck)=eij
18142 !el      endif
18143       enddo
18144       if (checkstop) then
18145         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18146       endif
18147       enddo
18148       if (checkstop) then
18149         transgrad=.true.
18150         checkstop=.false.
18151       endif
18152 !-------END TESTING CODE
18153
18154       do k=1,3
18155         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18156         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18157       enddo
18158       do k=1,3
18159         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18160       enddo
18161       do k=1,3
18162         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18163              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18164              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18165         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18166              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18167              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18168       enddo
18169 !grad      do k=i,j-1
18170 !grad        do l=1,3
18171 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18172 !grad        enddo
18173 !grad      enddo
18174
18175       do l=1,3
18176         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18177         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18178       enddo
18179
18180       return
18181       end subroutine dyn_ssbond_ene
18182 !--------------------------------------------------------------------------
18183          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18184 !      implicit none
18185 !      Includes
18186       use calc_data
18187       use comm_sschecks
18188 !      include 'DIMENSIONS'
18189 !      include 'COMMON.SBRIDGE'
18190 !      include 'COMMON.CHAIN'
18191 !      include 'COMMON.DERIV'
18192 !      include 'COMMON.LOCAL'
18193 !      include 'COMMON.INTERACT'
18194 !      include 'COMMON.VAR'
18195 !      include 'COMMON.IOUNITS'
18196 !      include 'COMMON.CALC'
18197 #ifndef CLUST
18198 #ifndef WHAM
18199        use MD_data
18200 !      include 'COMMON.MD'
18201 !      use MD, only: totT,t_bath
18202 #endif
18203 #endif
18204       double precision h_base
18205       external h_base
18206
18207 !c     Input arguments
18208       integer resi,resj,resk,m,itypi,itypj,itypk
18209
18210 !c     Output arguments
18211       double precision eij,eij1,eij2,eij3
18212
18213 !c     Local variables
18214       logical havebond
18215 !c      integer itypi,itypj,k,l
18216       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18217       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18218       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18219       double precision sig0ij,ljd,sig,fac,e1,e2
18220       double precision dcosom1(3),dcosom2(3),ed
18221       double precision pom1,pom2
18222       double precision ljA,ljB,ljXs
18223       double precision d_ljB(1:3)
18224       double precision ssA,ssB,ssC,ssXs
18225       double precision ssxm,ljxm,ssm,ljm
18226       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18227       eij=0.0
18228       if (dtriss.eq.0) return
18229       i=resi
18230       j=resj
18231       k=resk
18232 !C      write(iout,*) resi,resj,resk
18233       itypi=itype(i,1)
18234       dxi=dc_norm(1,nres+i)
18235       dyi=dc_norm(2,nres+i)
18236       dzi=dc_norm(3,nres+i)
18237       dsci_inv=vbld_inv(i+nres)
18238       xi=c(1,nres+i)
18239       yi=c(2,nres+i)
18240       zi=c(3,nres+i)
18241       itypj=itype(j,1)
18242       xj=c(1,nres+j)
18243       yj=c(2,nres+j)
18244       zj=c(3,nres+j)
18245
18246       dxj=dc_norm(1,nres+j)
18247       dyj=dc_norm(2,nres+j)
18248       dzj=dc_norm(3,nres+j)
18249       dscj_inv=vbld_inv(j+nres)
18250       itypk=itype(k,1)
18251       xk=c(1,nres+k)
18252       yk=c(2,nres+k)
18253       zk=c(3,nres+k)
18254
18255       dxk=dc_norm(1,nres+k)
18256       dyk=dc_norm(2,nres+k)
18257       dzk=dc_norm(3,nres+k)
18258       dscj_inv=vbld_inv(k+nres)
18259       xij=xj-xi
18260       xik=xk-xi
18261       xjk=xk-xj
18262       yij=yj-yi
18263       yik=yk-yi
18264       yjk=yk-yj
18265       zij=zj-zi
18266       zik=zk-zi
18267       zjk=zk-zj
18268       rrij=(xij*xij+yij*yij+zij*zij)
18269       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18270       rrik=(xik*xik+yik*yik+zik*zik)
18271       rik=dsqrt(rrik)
18272       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18273       rjk=dsqrt(rrjk)
18274 !C there are three combination of distances for each trisulfide bonds
18275 !C The first case the ith atom is the center
18276 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18277 !C distance y is second distance the a,b,c,d are parameters derived for
18278 !C this problem d parameter was set as a penalty currenlty set to 1.
18279       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18280       eij1=0.0d0
18281       else
18282       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18283       endif
18284 !C second case jth atom is center
18285       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18286       eij2=0.0d0
18287       else
18288       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18289       endif
18290 !C the third case kth atom is the center
18291       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18292       eij3=0.0d0
18293       else
18294       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18295       endif
18296 !C      eij2=0.0
18297 !C      eij3=0.0
18298 !C      eij1=0.0
18299       eij=eij1+eij2+eij3
18300 !C      write(iout,*)i,j,k,eij
18301 !C The energy penalty calculated now time for the gradient part
18302 !C derivative over rij
18303       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18304       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18305             gg(1)=xij*fac/rij
18306             gg(2)=yij*fac/rij
18307             gg(3)=zij*fac/rij
18308       do m=1,3
18309         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18310         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18311       enddo
18312
18313       do l=1,3
18314         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18315         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18316       enddo
18317 !C now derivative over rik
18318       fac=-eij1**2/dtriss* &
18319       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18320       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18321             gg(1)=xik*fac/rik
18322             gg(2)=yik*fac/rik
18323             gg(3)=zik*fac/rik
18324       do m=1,3
18325         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18326         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18327       enddo
18328       do l=1,3
18329         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18330         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18331       enddo
18332 !C now derivative over rjk
18333       fac=-eij2**2/dtriss* &
18334       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18335       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18336             gg(1)=xjk*fac/rjk
18337             gg(2)=yjk*fac/rjk
18338             gg(3)=zjk*fac/rjk
18339       do m=1,3
18340         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18341         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18342       enddo
18343       do l=1,3
18344         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18345         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18346       enddo
18347       return
18348       end subroutine triple_ssbond_ene
18349
18350
18351
18352 !-----------------------------------------------------------------------------
18353       real(kind=8) function h_base(x,deriv)
18354 !     A smooth function going 0->1 in range [0,1]
18355 !     It should NOT be called outside range [0,1], it will not work there.
18356       implicit none
18357
18358 !     Input arguments
18359       real(kind=8) :: x
18360
18361 !     Output arguments
18362       real(kind=8) :: deriv
18363
18364 !     Local variables
18365       real(kind=8) :: xsq
18366
18367
18368 !     Two parabolas put together.  First derivative zero at extrema
18369 !$$$      if (x.lt.0.5D0) then
18370 !$$$        h_base=2.0D0*x*x
18371 !$$$        deriv=4.0D0*x
18372 !$$$      else
18373 !$$$        deriv=1.0D0-x
18374 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18375 !$$$        deriv=4.0D0*deriv
18376 !$$$      endif
18377
18378 !     Third degree polynomial.  First derivative zero at extrema
18379       h_base=x*x*(3.0d0-2.0d0*x)
18380       deriv=6.0d0*x*(1.0d0-x)
18381
18382 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18383 !$$$      xsq=x*x
18384 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18385 !$$$      deriv=x-1.0d0
18386 !$$$      deriv=deriv*deriv
18387 !$$$      deriv=30.0d0*xsq*deriv
18388
18389       return
18390       end function h_base
18391 !-----------------------------------------------------------------------------
18392       subroutine dyn_set_nss
18393 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18394 !      implicit none
18395       use MD_data, only: totT,t_bath
18396 !     Includes
18397 !      include 'DIMENSIONS'
18398 #ifdef MPI
18399       include "mpif.h"
18400 #endif
18401 !      include 'COMMON.SBRIDGE'
18402 !      include 'COMMON.CHAIN'
18403 !      include 'COMMON.IOUNITS'
18404 !      include 'COMMON.SETUP'
18405 !      include 'COMMON.MD'
18406 !     Local variables
18407       real(kind=8) :: emin
18408       integer :: i,j,imin,ierr
18409       integer :: diff,allnss,newnss
18410       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18411                 newihpb,newjhpb
18412       logical :: found
18413       integer,dimension(0:nfgtasks) :: i_newnss
18414       integer,dimension(0:nfgtasks) :: displ
18415       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18416       integer :: g_newnss
18417
18418       allnss=0
18419       do i=1,nres-1
18420         do j=i+1,nres
18421           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18422             allnss=allnss+1
18423             allflag(allnss)=0
18424             allihpb(allnss)=i
18425             alljhpb(allnss)=j
18426           endif
18427         enddo
18428       enddo
18429
18430 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18431
18432  1    emin=1.0d300
18433       do i=1,allnss
18434         if (allflag(i).eq.0 .and. &
18435              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18436           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18437           imin=i
18438         endif
18439       enddo
18440       if (emin.lt.1.0d300) then
18441         allflag(imin)=1
18442         do i=1,allnss
18443           if (allflag(i).eq.0 .and. &
18444                (allihpb(i).eq.allihpb(imin) .or. &
18445                alljhpb(i).eq.allihpb(imin) .or. &
18446                allihpb(i).eq.alljhpb(imin) .or. &
18447                alljhpb(i).eq.alljhpb(imin))) then
18448             allflag(i)=-1
18449           endif
18450         enddo
18451         goto 1
18452       endif
18453
18454 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18455
18456       newnss=0
18457       do i=1,allnss
18458         if (allflag(i).eq.1) then
18459           newnss=newnss+1
18460           newihpb(newnss)=allihpb(i)
18461           newjhpb(newnss)=alljhpb(i)
18462         endif
18463       enddo
18464
18465 #ifdef MPI
18466       if (nfgtasks.gt.1)then
18467
18468         call MPI_Reduce(newnss,g_newnss,1,&
18469           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18470         call MPI_Gather(newnss,1,MPI_INTEGER,&
18471                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18472         displ(0)=0
18473         do i=1,nfgtasks-1,1
18474           displ(i)=i_newnss(i-1)+displ(i-1)
18475         enddo
18476         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18477                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18478                          king,FG_COMM,IERR)
18479         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18480                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18481                          king,FG_COMM,IERR)
18482         if(fg_rank.eq.0) then
18483 !         print *,'g_newnss',g_newnss
18484 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18485 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18486          newnss=g_newnss
18487          do i=1,newnss
18488           newihpb(i)=g_newihpb(i)
18489           newjhpb(i)=g_newjhpb(i)
18490          enddo
18491         endif
18492       endif
18493 #endif
18494
18495       diff=newnss-nss
18496
18497 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18498 !       print *,newnss,nss,maxdim
18499       do i=1,nss
18500         found=.false.
18501 !        print *,newnss
18502         do j=1,newnss
18503 !!          print *,j
18504           if (idssb(i).eq.newihpb(j) .and. &
18505                jdssb(i).eq.newjhpb(j)) found=.true.
18506         enddo
18507 #ifndef CLUST
18508 #ifndef WHAM
18509 !        write(iout,*) "found",found,i,j
18510         if (.not.found.and.fg_rank.eq.0) &
18511             write(iout,'(a15,f12.2,f8.1,2i5)') &
18512              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18513 #endif
18514 #endif
18515       enddo
18516
18517       do i=1,newnss
18518         found=.false.
18519         do j=1,nss
18520 !          print *,i,j
18521           if (newihpb(i).eq.idssb(j) .and. &
18522                newjhpb(i).eq.jdssb(j)) found=.true.
18523         enddo
18524 #ifndef CLUST
18525 #ifndef WHAM
18526 !        write(iout,*) "found",found,i,j
18527         if (.not.found.and.fg_rank.eq.0) &
18528             write(iout,'(a15,f12.2,f8.1,2i5)') &
18529              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18530 #endif
18531 #endif
18532       enddo
18533
18534       nss=newnss
18535       do i=1,nss
18536         idssb(i)=newihpb(i)
18537         jdssb(i)=newjhpb(i)
18538       enddo
18539
18540       return
18541       end subroutine dyn_set_nss
18542 ! Lipid transfer energy function
18543       subroutine Eliptransfer(eliptran)
18544 !C this is done by Adasko
18545 !C      print *,"wchodze"
18546 !C structure of box:
18547 !C      water
18548 !C--bordliptop-- buffore starts
18549 !C--bufliptop--- here true lipid starts
18550 !C      lipid
18551 !C--buflipbot--- lipid ends buffore starts
18552 !C--bordlipbot--buffore ends
18553       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18554       integer :: i
18555       eliptran=0.0
18556 !      print *, "I am in eliptran"
18557       do i=ilip_start,ilip_end
18558 !C       do i=1,1
18559         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18560          cycle
18561
18562         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18563         if (positi.le.0.0) positi=positi+boxzsize
18564 !C        print *,i
18565 !C first for peptide groups
18566 !c for each residue check if it is in lipid or lipid water border area
18567        if ((positi.gt.bordlipbot)  &
18568       .and.(positi.lt.bordliptop)) then
18569 !C the energy transfer exist
18570         if (positi.lt.buflipbot) then
18571 !C what fraction I am in
18572          fracinbuf=1.0d0-      &
18573              ((positi-bordlipbot)/lipbufthick)
18574 !C lipbufthick is thickenes of lipid buffore
18575          sslip=sscalelip(fracinbuf)
18576          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18577          eliptran=eliptran+sslip*pepliptran
18578          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18579          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18580 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18581
18582 !C        print *,"doing sccale for lower part"
18583 !C         print *,i,sslip,fracinbuf,ssgradlip
18584         elseif (positi.gt.bufliptop) then
18585          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18586          sslip=sscalelip(fracinbuf)
18587          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18588          eliptran=eliptran+sslip*pepliptran
18589          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18590          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18591 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18592 !C          print *, "doing sscalefor top part"
18593 !C         print *,i,sslip,fracinbuf,ssgradlip
18594         else
18595          eliptran=eliptran+pepliptran
18596 !C         print *,"I am in true lipid"
18597         endif
18598 !C       else
18599 !C       eliptran=elpitran+0.0 ! I am in water
18600        endif
18601        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18602        enddo
18603 ! here starts the side chain transfer
18604        do i=ilip_start,ilip_end
18605         if (itype(i,1).eq.ntyp1) cycle
18606         positi=(mod(c(3,i+nres),boxzsize))
18607         if (positi.le.0) positi=positi+boxzsize
18608 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18609 !c for each residue check if it is in lipid or lipid water border area
18610 !C       respos=mod(c(3,i+nres),boxzsize)
18611 !C       print *,positi,bordlipbot,buflipbot
18612        if ((positi.gt.bordlipbot) &
18613        .and.(positi.lt.bordliptop)) then
18614 !C the energy transfer exist
18615         if (positi.lt.buflipbot) then
18616          fracinbuf=1.0d0-   &
18617            ((positi-bordlipbot)/lipbufthick)
18618 !C lipbufthick is thickenes of lipid buffore
18619          sslip=sscalelip(fracinbuf)
18620          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18621          eliptran=eliptran+sslip*liptranene(itype(i,1))
18622          gliptranx(3,i)=gliptranx(3,i) &
18623       +ssgradlip*liptranene(itype(i,1))
18624          gliptranc(3,i-1)= gliptranc(3,i-1) &
18625       +ssgradlip*liptranene(itype(i,1))
18626 !C         print *,"doing sccale for lower part"
18627         elseif (positi.gt.bufliptop) then
18628          fracinbuf=1.0d0-  &
18629       ((bordliptop-positi)/lipbufthick)
18630          sslip=sscalelip(fracinbuf)
18631          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18632          eliptran=eliptran+sslip*liptranene(itype(i,1))
18633          gliptranx(3,i)=gliptranx(3,i)  &
18634        +ssgradlip*liptranene(itype(i,1))
18635          gliptranc(3,i-1)= gliptranc(3,i-1) &
18636       +ssgradlip*liptranene(itype(i,1))
18637 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18638         else
18639          eliptran=eliptran+liptranene(itype(i,1))
18640 !C         print *,"I am in true lipid"
18641         endif
18642         endif ! if in lipid or buffor
18643 !C       else
18644 !C       eliptran=elpitran+0.0 ! I am in water
18645         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18646        enddo
18647        return
18648        end  subroutine Eliptransfer
18649 !----------------------------------NANO FUNCTIONS
18650 !C-----------------------------------------------------------------------
18651 !C-----------------------------------------------------------
18652 !C This subroutine is to mimic the histone like structure but as well can be
18653 !C utilizet to nanostructures (infinit) small modification has to be used to
18654 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18655 !C gradient has to be modified at the ends
18656 !C The energy function is Kihara potential
18657 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18658 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18659 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18660 !C simple Kihara potential
18661       subroutine calctube(Etube)
18662       real(kind=8),dimension(3) :: vectube
18663       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18664        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18665        sc_aa_tube,sc_bb_tube
18666       integer :: i,j,iti
18667       Etube=0.0d0
18668       do i=itube_start,itube_end
18669         enetube(i)=0.0d0
18670         enetube(i+nres)=0.0d0
18671       enddo
18672 !C first we calculate the distance from tube center
18673 !C for UNRES
18674        do i=itube_start,itube_end
18675 !C lets ommit dummy atoms for now
18676        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18677 !C now calculate distance from center of tube and direction vectors
18678       xmin=boxxsize
18679       ymin=boxysize
18680 ! Find minimum distance in periodic box
18681         do j=-1,1
18682          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18683          vectube(1)=vectube(1)+boxxsize*j
18684          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18685          vectube(2)=vectube(2)+boxysize*j
18686          xminact=abs(vectube(1)-tubecenter(1))
18687          yminact=abs(vectube(2)-tubecenter(2))
18688            if (xmin.gt.xminact) then
18689             xmin=xminact
18690             xtemp=vectube(1)
18691            endif
18692            if (ymin.gt.yminact) then
18693              ymin=yminact
18694              ytemp=vectube(2)
18695             endif
18696          enddo
18697       vectube(1)=xtemp
18698       vectube(2)=ytemp
18699       vectube(1)=vectube(1)-tubecenter(1)
18700       vectube(2)=vectube(2)-tubecenter(2)
18701
18702 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18703 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18704
18705 !C as the tube is infinity we do not calculate the Z-vector use of Z
18706 !C as chosen axis
18707       vectube(3)=0.0d0
18708 !C now calculte the distance
18709        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18710 !C now normalize vector
18711       vectube(1)=vectube(1)/tub_r
18712       vectube(2)=vectube(2)/tub_r
18713 !C calculte rdiffrence between r and r0
18714       rdiff=tub_r-tubeR0
18715 !C and its 6 power
18716       rdiff6=rdiff**6.0d0
18717 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18718        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18719 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18720 !C       print *,rdiff,rdiff6,pep_aa_tube
18721 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18722 !C now we calculate gradient
18723        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18724             6.0d0*pep_bb_tube)/rdiff6/rdiff
18725 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18726 !C     &rdiff,fac
18727 !C now direction of gg_tube vector
18728         do j=1,3
18729         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18730         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18731         enddo
18732         enddo
18733 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18734 !C        print *,gg_tube(1,0),"TU"
18735
18736
18737        do i=itube_start,itube_end
18738 !C Lets not jump over memory as we use many times iti
18739          iti=itype(i,1)
18740 !C lets ommit dummy atoms for now
18741          if ((iti.eq.ntyp1)  &
18742 !C in UNRES uncomment the line below as GLY has no side-chain...
18743 !C      .or.(iti.eq.10)
18744         ) cycle
18745       xmin=boxxsize
18746       ymin=boxysize
18747         do j=-1,1
18748          vectube(1)=mod((c(1,i+nres)),boxxsize)
18749          vectube(1)=vectube(1)+boxxsize*j
18750          vectube(2)=mod((c(2,i+nres)),boxysize)
18751          vectube(2)=vectube(2)+boxysize*j
18752
18753          xminact=abs(vectube(1)-tubecenter(1))
18754          yminact=abs(vectube(2)-tubecenter(2))
18755            if (xmin.gt.xminact) then
18756             xmin=xminact
18757             xtemp=vectube(1)
18758            endif
18759            if (ymin.gt.yminact) then
18760              ymin=yminact
18761              ytemp=vectube(2)
18762             endif
18763          enddo
18764       vectube(1)=xtemp
18765       vectube(2)=ytemp
18766 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18767 !C     &     tubecenter(2)
18768       vectube(1)=vectube(1)-tubecenter(1)
18769       vectube(2)=vectube(2)-tubecenter(2)
18770
18771 !C as the tube is infinity we do not calculate the Z-vector use of Z
18772 !C as chosen axis
18773       vectube(3)=0.0d0
18774 !C now calculte the distance
18775        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18776 !C now normalize vector
18777       vectube(1)=vectube(1)/tub_r
18778       vectube(2)=vectube(2)/tub_r
18779
18780 !C calculte rdiffrence between r and r0
18781       rdiff=tub_r-tubeR0
18782 !C and its 6 power
18783       rdiff6=rdiff**6.0d0
18784 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18785        sc_aa_tube=sc_aa_tube_par(iti)
18786        sc_bb_tube=sc_bb_tube_par(iti)
18787        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18788        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18789              6.0d0*sc_bb_tube/rdiff6/rdiff
18790 !C now direction of gg_tube vector
18791          do j=1,3
18792           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18793           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18794          enddo
18795         enddo
18796         do i=itube_start,itube_end
18797           Etube=Etube+enetube(i)+enetube(i+nres)
18798         enddo
18799 !C        print *,"ETUBE", etube
18800         return
18801         end subroutine calctube
18802 !C TO DO 1) add to total energy
18803 !C       2) add to gradient summation
18804 !C       3) add reading parameters (AND of course oppening of PARAM file)
18805 !C       4) add reading the center of tube
18806 !C       5) add COMMONs
18807 !C       6) add to zerograd
18808 !C       7) allocate matrices
18809
18810
18811 !C-----------------------------------------------------------------------
18812 !C-----------------------------------------------------------
18813 !C This subroutine is to mimic the histone like structure but as well can be
18814 !C utilizet to nanostructures (infinit) small modification has to be used to
18815 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18816 !C gradient has to be modified at the ends
18817 !C The energy function is Kihara potential
18818 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18819 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18820 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18821 !C simple Kihara potential
18822       subroutine calctube2(Etube)
18823             real(kind=8),dimension(3) :: vectube
18824       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18825        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18826        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18827       integer:: i,j,iti
18828       Etube=0.0d0
18829       do i=itube_start,itube_end
18830         enetube(i)=0.0d0
18831         enetube(i+nres)=0.0d0
18832       enddo
18833 !C first we calculate the distance from tube center
18834 !C first sugare-phosphate group for NARES this would be peptide group
18835 !C for UNRES
18836        do i=itube_start,itube_end
18837 !C lets ommit dummy atoms for now
18838
18839        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18840 !C now calculate distance from center of tube and direction vectors
18841 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18842 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18843 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18844 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18845       xmin=boxxsize
18846       ymin=boxysize
18847         do j=-1,1
18848          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18849          vectube(1)=vectube(1)+boxxsize*j
18850          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18851          vectube(2)=vectube(2)+boxysize*j
18852
18853          xminact=abs(vectube(1)-tubecenter(1))
18854          yminact=abs(vectube(2)-tubecenter(2))
18855            if (xmin.gt.xminact) then
18856             xmin=xminact
18857             xtemp=vectube(1)
18858            endif
18859            if (ymin.gt.yminact) then
18860              ymin=yminact
18861              ytemp=vectube(2)
18862             endif
18863          enddo
18864       vectube(1)=xtemp
18865       vectube(2)=ytemp
18866       vectube(1)=vectube(1)-tubecenter(1)
18867       vectube(2)=vectube(2)-tubecenter(2)
18868
18869 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18870 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18871
18872 !C as the tube is infinity we do not calculate the Z-vector use of Z
18873 !C as chosen axis
18874       vectube(3)=0.0d0
18875 !C now calculte the distance
18876        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18877 !C now normalize vector
18878       vectube(1)=vectube(1)/tub_r
18879       vectube(2)=vectube(2)/tub_r
18880 !C calculte rdiffrence between r and r0
18881       rdiff=tub_r-tubeR0
18882 !C and its 6 power
18883       rdiff6=rdiff**6.0d0
18884 !C THIS FRAGMENT MAKES TUBE FINITE
18885         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18886         if (positi.le.0) positi=positi+boxzsize
18887 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18888 !c for each residue check if it is in lipid or lipid water border area
18889 !C       respos=mod(c(3,i+nres),boxzsize)
18890 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18891        if ((positi.gt.bordtubebot)  &
18892         .and.(positi.lt.bordtubetop)) then
18893 !C the energy transfer exist
18894         if (positi.lt.buftubebot) then
18895          fracinbuf=1.0d0-  &
18896            ((positi-bordtubebot)/tubebufthick)
18897 !C lipbufthick is thickenes of lipid buffore
18898          sstube=sscalelip(fracinbuf)
18899          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18900 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18901          enetube(i)=enetube(i)+sstube*tubetranenepep
18902 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18903 !C     &+ssgradtube*tubetranene(itype(i,1))
18904 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18905 !C     &+ssgradtube*tubetranene(itype(i,1))
18906 !C         print *,"doing sccale for lower part"
18907         elseif (positi.gt.buftubetop) then
18908          fracinbuf=1.0d0-  &
18909         ((bordtubetop-positi)/tubebufthick)
18910          sstube=sscalelip(fracinbuf)
18911          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18912          enetube(i)=enetube(i)+sstube*tubetranenepep
18913 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18914 !C     &+ssgradtube*tubetranene(itype(i,1))
18915 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18916 !C     &+ssgradtube*tubetranene(itype(i,1))
18917 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18918         else
18919          sstube=1.0d0
18920          ssgradtube=0.0d0
18921          enetube(i)=enetube(i)+sstube*tubetranenepep
18922 !C         print *,"I am in true lipid"
18923         endif
18924         else
18925 !C          sstube=0.0d0
18926 !C          ssgradtube=0.0d0
18927         cycle
18928         endif ! if in lipid or buffor
18929
18930 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18931        enetube(i)=enetube(i)+sstube* &
18932         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18933 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18934 !C       print *,rdiff,rdiff6,pep_aa_tube
18935 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18936 !C now we calculate gradient
18937        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18938              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18939 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18940 !C     &rdiff,fac
18941
18942 !C now direction of gg_tube vector
18943        do j=1,3
18944         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18945         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18946         enddo
18947          gg_tube(3,i)=gg_tube(3,i)  &
18948        +ssgradtube*enetube(i)/sstube/2.0d0
18949          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18950        +ssgradtube*enetube(i)/sstube/2.0d0
18951
18952         enddo
18953 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18954 !C        print *,gg_tube(1,0),"TU"
18955         do i=itube_start,itube_end
18956 !C Lets not jump over memory as we use many times iti
18957          iti=itype(i,1)
18958 !C lets ommit dummy atoms for now
18959          if ((iti.eq.ntyp1) &
18960 !!C in UNRES uncomment the line below as GLY has no side-chain...
18961            .or.(iti.eq.10) &
18962           ) cycle
18963           vectube(1)=c(1,i+nres)
18964           vectube(1)=mod(vectube(1),boxxsize)
18965           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18966           vectube(2)=c(2,i+nres)
18967           vectube(2)=mod(vectube(2),boxysize)
18968           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18969
18970       vectube(1)=vectube(1)-tubecenter(1)
18971       vectube(2)=vectube(2)-tubecenter(2)
18972 !C THIS FRAGMENT MAKES TUBE FINITE
18973         positi=(mod(c(3,i+nres),boxzsize))
18974         if (positi.le.0) positi=positi+boxzsize
18975 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18976 !c for each residue check if it is in lipid or lipid water border area
18977 !C       respos=mod(c(3,i+nres),boxzsize)
18978 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18979
18980        if ((positi.gt.bordtubebot)  &
18981         .and.(positi.lt.bordtubetop)) then
18982 !C the energy transfer exist
18983         if (positi.lt.buftubebot) then
18984          fracinbuf=1.0d0- &
18985             ((positi-bordtubebot)/tubebufthick)
18986 !C lipbufthick is thickenes of lipid buffore
18987          sstube=sscalelip(fracinbuf)
18988          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18989 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18990          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
18991 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18992 !C     &+ssgradtube*tubetranene(itype(i,1))
18993 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18994 !C     &+ssgradtube*tubetranene(itype(i,1))
18995 !C         print *,"doing sccale for lower part"
18996         elseif (positi.gt.buftubetop) then
18997          fracinbuf=1.0d0- &
18998         ((bordtubetop-positi)/tubebufthick)
18999
19000          sstube=sscalelip(fracinbuf)
19001          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19002          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19003 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19004 !C     &+ssgradtube*tubetranene(itype(i,1))
19005 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19006 !C     &+ssgradtube*tubetranene(itype(i,1))
19007 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19008         else
19009          sstube=1.0d0
19010          ssgradtube=0.0d0
19011          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19012 !C         print *,"I am in true lipid"
19013         endif
19014         else
19015 !C          sstube=0.0d0
19016 !C          ssgradtube=0.0d0
19017         cycle
19018         endif ! if in lipid or buffor
19019 !CEND OF FINITE FRAGMENT
19020 !C as the tube is infinity we do not calculate the Z-vector use of Z
19021 !C as chosen axis
19022       vectube(3)=0.0d0
19023 !C now calculte the distance
19024        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19025 !C now normalize vector
19026       vectube(1)=vectube(1)/tub_r
19027       vectube(2)=vectube(2)/tub_r
19028 !C calculte rdiffrence between r and r0
19029       rdiff=tub_r-tubeR0
19030 !C and its 6 power
19031       rdiff6=rdiff**6.0d0
19032 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19033        sc_aa_tube=sc_aa_tube_par(iti)
19034        sc_bb_tube=sc_bb_tube_par(iti)
19035        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19036                        *sstube+enetube(i+nres)
19037 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19038 !C now we calculate gradient
19039        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19040             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19041 !C now direction of gg_tube vector
19042          do j=1,3
19043           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19044           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19045          enddo
19046          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19047        +ssgradtube*enetube(i+nres)/sstube
19048          gg_tube(3,i-1)= gg_tube(3,i-1) &
19049        +ssgradtube*enetube(i+nres)/sstube
19050
19051         enddo
19052         do i=itube_start,itube_end
19053           Etube=Etube+enetube(i)+enetube(i+nres)
19054         enddo
19055 !C        print *,"ETUBE", etube
19056         return
19057         end subroutine calctube2
19058 !=====================================================================================================================================
19059       subroutine calcnano(Etube)
19060       real(kind=8),dimension(3) :: vectube
19061
19062       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19063        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19064        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19065        integer:: i,j,iti,r
19066
19067       Etube=0.0d0
19068 !      print *,itube_start,itube_end,"poczatek"
19069       do i=itube_start,itube_end
19070         enetube(i)=0.0d0
19071         enetube(i+nres)=0.0d0
19072       enddo
19073 !C first we calculate the distance from tube center
19074 !C first sugare-phosphate group for NARES this would be peptide group
19075 !C for UNRES
19076        do i=itube_start,itube_end
19077 !C lets ommit dummy atoms for now
19078        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19079 !C now calculate distance from center of tube and direction vectors
19080       xmin=boxxsize
19081       ymin=boxysize
19082       zmin=boxzsize
19083
19084         do j=-1,1
19085          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19086          vectube(1)=vectube(1)+boxxsize*j
19087          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19088          vectube(2)=vectube(2)+boxysize*j
19089          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19090          vectube(3)=vectube(3)+boxzsize*j
19091
19092
19093          xminact=dabs(vectube(1)-tubecenter(1))
19094          yminact=dabs(vectube(2)-tubecenter(2))
19095          zminact=dabs(vectube(3)-tubecenter(3))
19096
19097            if (xmin.gt.xminact) then
19098             xmin=xminact
19099             xtemp=vectube(1)
19100            endif
19101            if (ymin.gt.yminact) then
19102              ymin=yminact
19103              ytemp=vectube(2)
19104             endif
19105            if (zmin.gt.zminact) then
19106              zmin=zminact
19107              ztemp=vectube(3)
19108             endif
19109          enddo
19110       vectube(1)=xtemp
19111       vectube(2)=ytemp
19112       vectube(3)=ztemp
19113
19114       vectube(1)=vectube(1)-tubecenter(1)
19115       vectube(2)=vectube(2)-tubecenter(2)
19116       vectube(3)=vectube(3)-tubecenter(3)
19117
19118 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19119 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19120 !C as the tube is infinity we do not calculate the Z-vector use of Z
19121 !C as chosen axis
19122 !C      vectube(3)=0.0d0
19123 !C now calculte the distance
19124        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19125 !C now normalize vector
19126       vectube(1)=vectube(1)/tub_r
19127       vectube(2)=vectube(2)/tub_r
19128       vectube(3)=vectube(3)/tub_r
19129 !C calculte rdiffrence between r and r0
19130       rdiff=tub_r-tubeR0
19131 !C and its 6 power
19132       rdiff6=rdiff**6.0d0
19133 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19134        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19135 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19136 !C       print *,rdiff,rdiff6,pep_aa_tube
19137 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19138 !C now we calculate gradient
19139        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19140             6.0d0*pep_bb_tube)/rdiff6/rdiff
19141 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19142 !C     &rdiff,fac
19143          if (acavtubpep.eq.0.0d0) then
19144 !C go to 667
19145          enecavtube(i)=0.0
19146          faccav=0.0
19147          else
19148          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19149          enecavtube(i)=  &
19150         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19151         /denominator
19152          enecavtube(i)=0.0
19153          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19154         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19155         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19156         /denominator**2.0d0
19157 !C         faccav=0.0
19158 !C         fac=fac+faccav
19159 !C 667     continue
19160          endif
19161           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19162         do j=1,3
19163         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19164         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19165         enddo
19166         enddo
19167
19168        do i=itube_start,itube_end
19169         enecavtube(i)=0.0d0
19170 !C Lets not jump over memory as we use many times iti
19171          iti=itype(i,1)
19172 !C lets ommit dummy atoms for now
19173          if ((iti.eq.ntyp1) &
19174 !C in UNRES uncomment the line below as GLY has no side-chain...
19175 !C      .or.(iti.eq.10)
19176          ) cycle
19177       xmin=boxxsize
19178       ymin=boxysize
19179       zmin=boxzsize
19180         do j=-1,1
19181          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19182          vectube(1)=vectube(1)+boxxsize*j
19183          vectube(2)=dmod((c(2,i+nres)),boxysize)
19184          vectube(2)=vectube(2)+boxysize*j
19185          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19186          vectube(3)=vectube(3)+boxzsize*j
19187
19188
19189          xminact=dabs(vectube(1)-tubecenter(1))
19190          yminact=dabs(vectube(2)-tubecenter(2))
19191          zminact=dabs(vectube(3)-tubecenter(3))
19192
19193            if (xmin.gt.xminact) then
19194             xmin=xminact
19195             xtemp=vectube(1)
19196            endif
19197            if (ymin.gt.yminact) then
19198              ymin=yminact
19199              ytemp=vectube(2)
19200             endif
19201            if (zmin.gt.zminact) then
19202              zmin=zminact
19203              ztemp=vectube(3)
19204             endif
19205          enddo
19206       vectube(1)=xtemp
19207       vectube(2)=ytemp
19208       vectube(3)=ztemp
19209
19210 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19211 !C     &     tubecenter(2)
19212       vectube(1)=vectube(1)-tubecenter(1)
19213       vectube(2)=vectube(2)-tubecenter(2)
19214       vectube(3)=vectube(3)-tubecenter(3)
19215 !C now calculte the distance
19216        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19217 !C now normalize vector
19218       vectube(1)=vectube(1)/tub_r
19219       vectube(2)=vectube(2)/tub_r
19220       vectube(3)=vectube(3)/tub_r
19221
19222 !C calculte rdiffrence between r and r0
19223       rdiff=tub_r-tubeR0
19224 !C and its 6 power
19225       rdiff6=rdiff**6.0d0
19226        sc_aa_tube=sc_aa_tube_par(iti)
19227        sc_bb_tube=sc_bb_tube_par(iti)
19228        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19229 !C       enetube(i+nres)=0.0d0
19230 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19231 !C now we calculate gradient
19232        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19233             6.0d0*sc_bb_tube/rdiff6/rdiff
19234 !C       fac=0.0
19235 !C now direction of gg_tube vector
19236 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19237          if (acavtub(iti).eq.0.0d0) then
19238 !C go to 667
19239          enecavtube(i+nres)=0.0d0
19240          faccav=0.0d0
19241          else
19242          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19243          enecavtube(i+nres)=   &
19244         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19245         /denominator
19246 !C         enecavtube(i)=0.0
19247          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19248         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19249         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19250         /denominator**2.0d0
19251 !C         faccav=0.0
19252          fac=fac+faccav
19253 !C 667     continue
19254          endif
19255 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19256 !C     &   enecavtube(i),faccav
19257 !C         print *,"licz=",
19258 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19259 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19260          do j=1,3
19261           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19262           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19263          enddo
19264           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19265         enddo
19266
19267
19268
19269         do i=itube_start,itube_end
19270           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19271          +enecavtube(i+nres)
19272         enddo
19273 !        do i=1,20
19274 !         print *,"begin", i,"a"
19275 !         do r=1,10000
19276 !          rdiff=r/100.0d0
19277 !          rdiff6=rdiff**6.0d0
19278 !          sc_aa_tube=sc_aa_tube_par(i)
19279 !          sc_bb_tube=sc_bb_tube_par(i)
19280 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19281 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19282 !          enecavtube(i)=   &
19283 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19284 !         /denominator
19285
19286 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19287 !         enddo
19288 !         print *,"end",i,"a"
19289 !        enddo
19290 !C        print *,"ETUBE", etube
19291         return
19292         end subroutine calcnano
19293
19294 !===============================================
19295 !--------------------------------------------------------------------------------
19296 !C first for shielding is setting of function of side-chains
19297
19298        subroutine set_shield_fac2
19299        real(kind=8) :: div77_81=0.974996043d0, &
19300         div4_81=0.2222222222d0
19301        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19302          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19303          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19304          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19305 !C the vector between center of side_chain and peptide group
19306        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19307          pept_group,costhet_grad,cosphi_grad_long, &
19308          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19309          sh_frac_dist_grad,pep_side
19310         integer i,j,k
19311 !C      write(2,*) "ivec",ivec_start,ivec_end
19312       do i=1,nres
19313         fac_shield(i)=0.0d0
19314         do j=1,3
19315         grad_shield(j,i)=0.0d0
19316         enddo
19317       enddo
19318       do i=ivec_start,ivec_end
19319 !C      do i=1,nres-1
19320 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19321       ishield_list(i)=0
19322       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19323 !Cif there two consequtive dummy atoms there is no peptide group between them
19324 !C the line below has to be changed for FGPROC>1
19325       VolumeTotal=0.0
19326       do k=1,nres
19327        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19328        dist_pep_side=0.0
19329        dist_side_calf=0.0
19330        do j=1,3
19331 !C first lets set vector conecting the ithe side-chain with kth side-chain
19332       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19333 !C      pep_side(j)=2.0d0
19334 !C and vector conecting the side-chain with its proper calfa
19335       side_calf(j)=c(j,k+nres)-c(j,k)
19336 !C      side_calf(j)=2.0d0
19337       pept_group(j)=c(j,i)-c(j,i+1)
19338 !C lets have their lenght
19339       dist_pep_side=pep_side(j)**2+dist_pep_side
19340       dist_side_calf=dist_side_calf+side_calf(j)**2
19341       dist_pept_group=dist_pept_group+pept_group(j)**2
19342       enddo
19343        dist_pep_side=sqrt(dist_pep_side)
19344        dist_pept_group=sqrt(dist_pept_group)
19345        dist_side_calf=sqrt(dist_side_calf)
19346       do j=1,3
19347         pep_side_norm(j)=pep_side(j)/dist_pep_side
19348         side_calf_norm(j)=dist_side_calf
19349       enddo
19350 !C now sscale fraction
19351        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19352 !C       print *,buff_shield,"buff"
19353 !C now sscale
19354         if (sh_frac_dist.le.0.0) cycle
19355 !C        print *,ishield_list(i),i
19356 !C If we reach here it means that this side chain reaches the shielding sphere
19357 !C Lets add him to the list for gradient
19358         ishield_list(i)=ishield_list(i)+1
19359 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19360 !C this list is essential otherwise problem would be O3
19361         shield_list(ishield_list(i),i)=k
19362 !C Lets have the sscale value
19363         if (sh_frac_dist.gt.1.0) then
19364          scale_fac_dist=1.0d0
19365          do j=1,3
19366          sh_frac_dist_grad(j)=0.0d0
19367          enddo
19368         else
19369          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19370                         *(2.0d0*sh_frac_dist-3.0d0)
19371          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19372                        /dist_pep_side/buff_shield*0.5d0
19373          do j=1,3
19374          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19375 !C         sh_frac_dist_grad(j)=0.0d0
19376 !C         scale_fac_dist=1.0d0
19377 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19378 !C     &                    sh_frac_dist_grad(j)
19379          enddo
19380         endif
19381 !C this is what is now we have the distance scaling now volume...
19382       short=short_r_sidechain(itype(k,1))
19383       long=long_r_sidechain(itype(k,1))
19384       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19385       sinthet=short/dist_pep_side*costhet
19386 !C now costhet_grad
19387 !C       costhet=0.6d0
19388 !C       sinthet=0.8
19389        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19390 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19391 !C     &             -short/dist_pep_side**2/costhet)
19392 !C       costhet_fac=0.0d0
19393        do j=1,3
19394          costhet_grad(j)=costhet_fac*pep_side(j)
19395        enddo
19396 !C remember for the final gradient multiply costhet_grad(j)
19397 !C for side_chain by factor -2 !
19398 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19399 !C pep_side0pept_group is vector multiplication
19400       pep_side0pept_group=0.0d0
19401       do j=1,3
19402       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19403       enddo
19404       cosalfa=(pep_side0pept_group/ &
19405       (dist_pep_side*dist_side_calf))
19406       fac_alfa_sin=1.0d0-cosalfa**2
19407       fac_alfa_sin=dsqrt(fac_alfa_sin)
19408       rkprim=fac_alfa_sin*(long-short)+short
19409 !C      rkprim=short
19410
19411 !C now costhet_grad
19412        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19413 !C       cosphi=0.6
19414        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19415        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19416            dist_pep_side**2)
19417 !C       sinphi=0.8
19418        do j=1,3
19419          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19420       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19421       *(long-short)/fac_alfa_sin*cosalfa/ &
19422       ((dist_pep_side*dist_side_calf))* &
19423       ((side_calf(j))-cosalfa* &
19424       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19425 !C       cosphi_grad_long(j)=0.0d0
19426         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19427       *(long-short)/fac_alfa_sin*cosalfa &
19428       /((dist_pep_side*dist_side_calf))* &
19429       (pep_side(j)- &
19430       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19431 !C       cosphi_grad_loc(j)=0.0d0
19432        enddo
19433 !C      print *,sinphi,sinthet
19434       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19435      &                    /VSolvSphere_div
19436 !C     &                    *wshield
19437 !C now the gradient...
19438       do j=1,3
19439       grad_shield(j,i)=grad_shield(j,i) &
19440 !C gradient po skalowaniu
19441                      +(sh_frac_dist_grad(j)*VofOverlap &
19442 !C  gradient po costhet
19443             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19444         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19445             sinphi/sinthet*costhet*costhet_grad(j) &
19446            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19447         )*wshield
19448 !C grad_shield_side is Cbeta sidechain gradient
19449       grad_shield_side(j,ishield_list(i),i)=&
19450              (sh_frac_dist_grad(j)*-2.0d0&
19451              *VofOverlap&
19452             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19453        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19454             sinphi/sinthet*costhet*costhet_grad(j)&
19455            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19456             )*wshield
19457
19458        grad_shield_loc(j,ishield_list(i),i)=   &
19459             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19460       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19461             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19462              ))&
19463              *wshield
19464       enddo
19465       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19466       enddo
19467       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19468
19469 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19470       enddo
19471       return
19472       end subroutine set_shield_fac2
19473 !----------------------------------------------------------------------------
19474 ! SOUBROUTINE FOR AFM
19475        subroutine AFMvel(Eafmforce)
19476        use MD_data, only:totTafm
19477       real(kind=8),dimension(3) :: diffafm
19478       real(kind=8) :: afmdist,Eafmforce
19479        integer :: i
19480 !C Only for check grad COMMENT if not used for checkgrad
19481 !C      totT=3.0d0
19482 !C--------------------------------------------------------
19483 !C      print *,"wchodze"
19484       afmdist=0.0d0
19485       Eafmforce=0.0d0
19486       do i=1,3
19487       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19488       afmdist=afmdist+diffafm(i)**2
19489       enddo
19490       afmdist=dsqrt(afmdist)
19491 !      totTafm=3.0
19492       Eafmforce=0.5d0*forceAFMconst &
19493       *(distafminit+totTafm*velAFMconst-afmdist)**2
19494 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19495       do i=1,3
19496       gradafm(i,afmend-1)=-forceAFMconst* &
19497        (distafminit+totTafm*velAFMconst-afmdist) &
19498        *diffafm(i)/afmdist
19499       gradafm(i,afmbeg-1)=forceAFMconst* &
19500       (distafminit+totTafm*velAFMconst-afmdist) &
19501       *diffafm(i)/afmdist
19502       enddo
19503 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19504       return
19505       end subroutine AFMvel
19506 !---------------------------------------------------------
19507        subroutine AFMforce(Eafmforce)
19508
19509       real(kind=8),dimension(3) :: diffafm
19510 !      real(kind=8) ::afmdist
19511       real(kind=8) :: afmdist,Eafmforce
19512       integer :: i
19513       afmdist=0.0d0
19514       Eafmforce=0.0d0
19515       do i=1,3
19516       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19517       afmdist=afmdist+diffafm(i)**2
19518       enddo
19519       afmdist=dsqrt(afmdist)
19520 !      print *,afmdist,distafminit
19521       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19522       do i=1,3
19523       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19524       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19525       enddo
19526 !C      print *,'AFM',Eafmforce
19527       return
19528       end subroutine AFMforce
19529
19530 !-----------------------------------------------------------------------------
19531 #ifdef WHAM
19532       subroutine read_ssHist
19533 !      implicit none
19534 !      Includes
19535 !      include 'DIMENSIONS'
19536 !      include "DIMENSIONS.FREE"
19537 !      include 'COMMON.FREE'
19538 !     Local variables
19539       integer :: i,j
19540       character(len=80) :: controlcard
19541
19542       do i=1,dyn_nssHist
19543         call card_concat(controlcard,.true.)
19544         read(controlcard,*) &
19545              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19546       enddo
19547
19548       return
19549       end subroutine read_ssHist
19550 #endif
19551 !-----------------------------------------------------------------------------
19552       integer function indmat(i,j)
19553 !el
19554 ! get the position of the jth ijth fragment of the chain coordinate system
19555 ! in the fromto array.
19556         integer :: i,j
19557
19558         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19559       return
19560       end function indmat
19561 !-----------------------------------------------------------------------------
19562       real(kind=8) function sigm(x)
19563 !el
19564        real(kind=8) :: x
19565         sigm=0.25d0*x
19566       return
19567       end function sigm
19568 !-----------------------------------------------------------------------------
19569 !-----------------------------------------------------------------------------
19570       subroutine alloc_ener_arrays
19571 !EL Allocation of arrays used by module energy
19572       use MD_data, only: mset
19573 !el local variables
19574       integer :: i,j
19575
19576       if(nres.lt.100) then
19577         maxconts=nres
19578       elseif(nres.lt.200) then
19579         maxconts=0.8*nres      ! Max. number of contacts per residue
19580       else
19581         maxconts=0.6*nres ! (maxconts=maxres/4)
19582       endif
19583       maxcont=12*nres      ! Max. number of SC contacts
19584       maxvar=6*nres      ! Max. number of variables
19585 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19586       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19587 !----------------------
19588 ! arrays in subroutine init_int_table
19589 !el#ifdef MPI
19590 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19591 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19592 !el#endif
19593       allocate(nint_gr(nres))
19594       allocate(nscp_gr(nres))
19595       allocate(ielstart(nres))
19596       allocate(ielend(nres))
19597 !(maxres)
19598       allocate(istart(nres,maxint_gr))
19599       allocate(iend(nres,maxint_gr))
19600 !(maxres,maxint_gr)
19601       allocate(iscpstart(nres,maxint_gr))
19602       allocate(iscpend(nres,maxint_gr))
19603 !(maxres,maxint_gr)
19604       allocate(ielstart_vdw(nres))
19605       allocate(ielend_vdw(nres))
19606 !(maxres)
19607       allocate(nint_gr_nucl(nres))
19608       allocate(nscp_gr_nucl(nres))
19609       allocate(ielstart_nucl(nres))
19610       allocate(ielend_nucl(nres))
19611 !(maxres)
19612       allocate(istart_nucl(nres,maxint_gr))
19613       allocate(iend_nucl(nres,maxint_gr))
19614 !(maxres,maxint_gr)
19615       allocate(iscpstart_nucl(nres,maxint_gr))
19616       allocate(iscpend_nucl(nres,maxint_gr))
19617 !(maxres,maxint_gr)
19618       allocate(ielstart_vdw_nucl(nres))
19619       allocate(ielend_vdw_nucl(nres))
19620
19621       allocate(lentyp(0:nfgtasks-1))
19622 !(0:maxprocs-1)
19623 !----------------------
19624 ! commom.contacts
19625 !      common /contacts/
19626       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19627       allocate(icont(2,maxcont))
19628 !(2,maxcont)
19629 !      common /contacts1/
19630       allocate(num_cont(0:nres+4))
19631 !(maxres)
19632       allocate(jcont(maxconts,nres))
19633 !(maxconts,maxres)
19634       allocate(facont(maxconts,nres))
19635 !(maxconts,maxres)
19636       allocate(gacont(3,maxconts,nres))
19637 !(3,maxconts,maxres)
19638 !      common /contacts_hb/
19639       allocate(gacontp_hb1(3,maxconts,nres))
19640       allocate(gacontp_hb2(3,maxconts,nres))
19641       allocate(gacontp_hb3(3,maxconts,nres))
19642       allocate(gacontm_hb1(3,maxconts,nres))
19643       allocate(gacontm_hb2(3,maxconts,nres))
19644       allocate(gacontm_hb3(3,maxconts,nres))
19645       allocate(gacont_hbr(3,maxconts,nres))
19646       allocate(grij_hb_cont(3,maxconts,nres))
19647 !(3,maxconts,maxres)
19648       allocate(facont_hb(maxconts,nres))
19649
19650       allocate(ees0p(maxconts,nres))
19651       allocate(ees0m(maxconts,nres))
19652       allocate(d_cont(maxconts,nres))
19653       allocate(ees0plist(maxconts,nres))
19654
19655 !(maxconts,maxres)
19656       allocate(num_cont_hb(nres))
19657 !(maxres)
19658       allocate(jcont_hb(maxconts,nres))
19659 !(maxconts,maxres)
19660 !      common /rotat/
19661       allocate(Ug(2,2,nres))
19662       allocate(Ugder(2,2,nres))
19663       allocate(Ug2(2,2,nres))
19664       allocate(Ug2der(2,2,nres))
19665 !(2,2,maxres)
19666       allocate(obrot(2,nres))
19667       allocate(obrot2(2,nres))
19668       allocate(obrot_der(2,nres))
19669       allocate(obrot2_der(2,nres))
19670 !(2,maxres)
19671 !      common /precomp1/
19672       allocate(mu(2,nres))
19673       allocate(muder(2,nres))
19674       allocate(Ub2(2,nres))
19675       Ub2(1,:)=0.0d0
19676       Ub2(2,:)=0.0d0
19677       allocate(Ub2der(2,nres))
19678       allocate(Ctobr(2,nres))
19679       allocate(Ctobrder(2,nres))
19680       allocate(Dtobr2(2,nres))
19681       allocate(Dtobr2der(2,nres))
19682 !(2,maxres)
19683       allocate(EUg(2,2,nres))
19684       allocate(EUgder(2,2,nres))
19685       allocate(CUg(2,2,nres))
19686       allocate(CUgder(2,2,nres))
19687       allocate(DUg(2,2,nres))
19688       allocate(Dugder(2,2,nres))
19689       allocate(DtUg2(2,2,nres))
19690       allocate(DtUg2der(2,2,nres))
19691 !(2,2,maxres)
19692 !      common /precomp2/
19693       allocate(Ug2Db1t(2,nres))
19694       allocate(Ug2Db1tder(2,nres))
19695       allocate(CUgb2(2,nres))
19696       allocate(CUgb2der(2,nres))
19697 !(2,maxres)
19698       allocate(EUgC(2,2,nres))
19699       allocate(EUgCder(2,2,nres))
19700       allocate(EUgD(2,2,nres))
19701       allocate(EUgDder(2,2,nres))
19702       allocate(DtUg2EUg(2,2,nres))
19703       allocate(Ug2DtEUg(2,2,nres))
19704 !(2,2,maxres)
19705       allocate(Ug2DtEUgder(2,2,2,nres))
19706       allocate(DtUg2EUgder(2,2,2,nres))
19707 !(2,2,2,maxres)
19708 !      common /rotat_old/
19709       allocate(costab(nres))
19710       allocate(sintab(nres))
19711       allocate(costab2(nres))
19712       allocate(sintab2(nres))
19713 !(maxres)
19714 !      common /dipmat/
19715       allocate(a_chuj(2,2,maxconts,nres))
19716 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19717       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19718 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19719 !      common /contdistrib/
19720       allocate(ncont_sent(nres))
19721       allocate(ncont_recv(nres))
19722
19723       allocate(iat_sent(nres))
19724 !(maxres)
19725       allocate(iint_sent(4,nres,nres))
19726       allocate(iint_sent_local(4,nres,nres))
19727 !(4,maxres,maxres)
19728       allocate(iturn3_sent(4,0:nres+4))
19729       allocate(iturn4_sent(4,0:nres+4))
19730       allocate(iturn3_sent_local(4,nres))
19731       allocate(iturn4_sent_local(4,nres))
19732 !(4,maxres)
19733       allocate(itask_cont_from(0:nfgtasks-1))
19734       allocate(itask_cont_to(0:nfgtasks-1))
19735 !(0:max_fg_procs-1)
19736
19737
19738
19739 !----------------------
19740 ! commom.deriv;
19741 !      common /derivat/
19742       allocate(dcdv(6,maxdim))
19743       allocate(dxdv(6,maxdim))
19744 !(6,maxdim)
19745       allocate(dxds(6,nres))
19746 !(6,maxres)
19747       allocate(gradx(3,-1:nres,0:2))
19748       allocate(gradc(3,-1:nres,0:2))
19749 !(3,maxres,2)
19750       allocate(gvdwx(3,-1:nres))
19751       allocate(gvdwc(3,-1:nres))
19752       allocate(gelc(3,-1:nres))
19753       allocate(gelc_long(3,-1:nres))
19754       allocate(gvdwpp(3,-1:nres))
19755       allocate(gvdwc_scpp(3,-1:nres))
19756       allocate(gradx_scp(3,-1:nres))
19757       allocate(gvdwc_scp(3,-1:nres))
19758       allocate(ghpbx(3,-1:nres))
19759       allocate(ghpbc(3,-1:nres))
19760       allocate(gradcorr(3,-1:nres))
19761       allocate(gradcorr_long(3,-1:nres))
19762       allocate(gradcorr5_long(3,-1:nres))
19763       allocate(gradcorr6_long(3,-1:nres))
19764       allocate(gcorr6_turn_long(3,-1:nres))
19765       allocate(gradxorr(3,-1:nres))
19766       allocate(gradcorr5(3,-1:nres))
19767       allocate(gradcorr6(3,-1:nres))
19768       allocate(gliptran(3,-1:nres))
19769       allocate(gliptranc(3,-1:nres))
19770       allocate(gliptranx(3,-1:nres))
19771       allocate(gshieldx(3,-1:nres))
19772       allocate(gshieldc(3,-1:nres))
19773       allocate(gshieldc_loc(3,-1:nres))
19774       allocate(gshieldx_ec(3,-1:nres))
19775       allocate(gshieldc_ec(3,-1:nres))
19776       allocate(gshieldc_loc_ec(3,-1:nres))
19777       allocate(gshieldx_t3(3,-1:nres))
19778       allocate(gshieldc_t3(3,-1:nres))
19779       allocate(gshieldc_loc_t3(3,-1:nres))
19780       allocate(gshieldx_t4(3,-1:nres))
19781       allocate(gshieldc_t4(3,-1:nres))
19782       allocate(gshieldc_loc_t4(3,-1:nres))
19783       allocate(gshieldx_ll(3,-1:nres))
19784       allocate(gshieldc_ll(3,-1:nres))
19785       allocate(gshieldc_loc_ll(3,-1:nres))
19786       allocate(grad_shield(3,-1:nres))
19787       allocate(gg_tube_sc(3,-1:nres))
19788       allocate(gg_tube(3,-1:nres))
19789       allocate(gradafm(3,-1:nres))
19790       allocate(gradb_nucl(3,-1:nres))
19791       allocate(gradbx_nucl(3,-1:nres))
19792       allocate(gvdwpsb1(3,-1:nres))
19793       allocate(gelpp(3,-1:nres))
19794       allocate(gvdwpsb(3,-1:nres))
19795       allocate(gelsbc(3,-1:nres))
19796       allocate(gelsbx(3,-1:nres))
19797       allocate(gvdwsbx(3,-1:nres))
19798       allocate(gvdwsbc(3,-1:nres))
19799       allocate(gsbloc(3,-1:nres))
19800       allocate(gsblocx(3,-1:nres))
19801       allocate(gradcorr_nucl(3,-1:nres))
19802       allocate(gradxorr_nucl(3,-1:nres))
19803       allocate(gradcorr3_nucl(3,-1:nres))
19804       allocate(gradxorr3_nucl(3,-1:nres))
19805       allocate(gvdwpp_nucl(3,-1:nres))
19806       allocate(gradpepcat(3,-1:nres))
19807       allocate(gradpepcatx(3,-1:nres))
19808       allocate(gradcatcat(3,-1:nres))
19809 !(3,maxres)
19810       allocate(grad_shield_side(3,50,nres))
19811       allocate(grad_shield_loc(3,50,nres))
19812 ! grad for shielding surroing
19813       allocate(gloc(0:maxvar,0:2))
19814       allocate(gloc_x(0:maxvar,2))
19815 !(maxvar,2)
19816       allocate(gel_loc(3,-1:nres))
19817       allocate(gel_loc_long(3,-1:nres))
19818       allocate(gcorr3_turn(3,-1:nres))
19819       allocate(gcorr4_turn(3,-1:nres))
19820       allocate(gcorr6_turn(3,-1:nres))
19821       allocate(gradb(3,-1:nres))
19822       allocate(gradbx(3,-1:nres))
19823 !(3,maxres)
19824       allocate(gel_loc_loc(maxvar))
19825       allocate(gel_loc_turn3(maxvar))
19826       allocate(gel_loc_turn4(maxvar))
19827       allocate(gel_loc_turn6(maxvar))
19828       allocate(gcorr_loc(maxvar))
19829       allocate(g_corr5_loc(maxvar))
19830       allocate(g_corr6_loc(maxvar))
19831 !(maxvar)
19832       allocate(gsccorc(3,-1:nres))
19833       allocate(gsccorx(3,-1:nres))
19834 !(3,maxres)
19835       allocate(gsccor_loc(-1:nres))
19836 !(maxres)
19837       allocate(gvdwx_scbase(3,-1:nres))
19838       allocate(gvdwc_scbase(3,-1:nres))
19839       allocate(gvdwx_pepbase(3,-1:nres))
19840       allocate(gvdwc_pepbase(3,-1:nres))
19841       allocate(gvdwx_scpho(3,-1:nres))
19842       allocate(gvdwc_scpho(3,-1:nres))
19843       allocate(gvdwc_peppho(3,-1:nres))
19844
19845       allocate(dtheta(3,2,-1:nres))
19846 !(3,2,maxres)
19847       allocate(gscloc(3,-1:nres))
19848       allocate(gsclocx(3,-1:nres))
19849 !(3,maxres)
19850       allocate(dphi(3,3,-1:nres))
19851       allocate(dalpha(3,3,-1:nres))
19852       allocate(domega(3,3,-1:nres))
19853 !(3,3,maxres)
19854 !      common /deriv_scloc/
19855       allocate(dXX_C1tab(3,nres))
19856       allocate(dYY_C1tab(3,nres))
19857       allocate(dZZ_C1tab(3,nres))
19858       allocate(dXX_Ctab(3,nres))
19859       allocate(dYY_Ctab(3,nres))
19860       allocate(dZZ_Ctab(3,nres))
19861       allocate(dXX_XYZtab(3,nres))
19862       allocate(dYY_XYZtab(3,nres))
19863       allocate(dZZ_XYZtab(3,nres))
19864 !(3,maxres)
19865 !      common /mpgrad/
19866       allocate(jgrad_start(nres))
19867       allocate(jgrad_end(nres))
19868 !(maxres)
19869 !----------------------
19870
19871 !      common /indices/
19872       allocate(ibond_displ(0:nfgtasks-1))
19873       allocate(ibond_count(0:nfgtasks-1))
19874       allocate(ithet_displ(0:nfgtasks-1))
19875       allocate(ithet_count(0:nfgtasks-1))
19876       allocate(iphi_displ(0:nfgtasks-1))
19877       allocate(iphi_count(0:nfgtasks-1))
19878       allocate(iphi1_displ(0:nfgtasks-1))
19879       allocate(iphi1_count(0:nfgtasks-1))
19880       allocate(ivec_displ(0:nfgtasks-1))
19881       allocate(ivec_count(0:nfgtasks-1))
19882       allocate(iset_displ(0:nfgtasks-1))
19883       allocate(iset_count(0:nfgtasks-1))
19884       allocate(iint_count(0:nfgtasks-1))
19885       allocate(iint_displ(0:nfgtasks-1))
19886 !(0:max_fg_procs-1)
19887 !----------------------
19888 ! common.MD
19889 !      common /mdgrad/
19890       allocate(gcart(3,-1:nres))
19891       allocate(gxcart(3,-1:nres))
19892 !(3,0:MAXRES)
19893       allocate(gradcag(3,-1:nres))
19894       allocate(gradxag(3,-1:nres))
19895 !(3,MAXRES)
19896 !      common /back_constr/
19897 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19898       allocate(dutheta(nres))
19899       allocate(dugamma(nres))
19900 !(maxres)
19901       allocate(duscdiff(3,nres))
19902       allocate(duscdiffx(3,nres))
19903 !(3,maxres)
19904 !el i io:read_fragments
19905 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19906 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19907 !      common /qmeas/
19908 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19909 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19910       allocate(mset(0:nprocs))  !(maxprocs/20)
19911       mset(:)=0
19912 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19913 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19914       allocate(dUdconst(3,0:nres))
19915       allocate(dUdxconst(3,0:nres))
19916       allocate(dqwol(3,0:nres))
19917       allocate(dxqwol(3,0:nres))
19918 !(3,0:MAXRES)
19919 !----------------------
19920 ! common.sbridge
19921 !      common /sbridge/ in io_common: read_bridge
19922 !el    allocate((:),allocatable :: iss      !(maxss)
19923 !      common /links/  in io_common: read_bridge
19924 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19925 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19926 !      common /dyn_ssbond/
19927 ! and side-chain vectors in theta or phi.
19928       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19929 !(maxres,maxres)
19930 !      do i=1,nres
19931 !        do j=i+1,nres
19932       dyn_ssbond_ij(:,:)=1.0d300
19933 !        enddo
19934 !      enddo
19935
19936 !      if (nss.gt.0) then
19937         allocate(idssb(maxdim),jdssb(maxdim))
19938 !        allocate(newihpb(nss),newjhpb(nss))
19939 !(maxdim)
19940 !      endif
19941       allocate(ishield_list(nres))
19942       allocate(shield_list(50,nres))
19943       allocate(dyn_ss_mask(nres))
19944       allocate(fac_shield(nres))
19945       allocate(enetube(nres*2))
19946       allocate(enecavtube(nres*2))
19947
19948 !(maxres)
19949       dyn_ss_mask(:)=.false.
19950 !----------------------
19951 ! common.sccor
19952 ! Parameters of the SCCOR term
19953 !      common/sccor/
19954 !el in io_conf: parmread
19955 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19956 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19957 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19958 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19959 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19960 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19961 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19962 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19963 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
19964 !----------------
19965       allocate(gloc_sc(3,0:2*nres,0:10))
19966 !(3,0:maxres2,10)maxres2=2*maxres
19967       allocate(dcostau(3,3,3,2*nres))
19968       allocate(dsintau(3,3,3,2*nres))
19969       allocate(dtauangle(3,3,3,2*nres))
19970       allocate(dcosomicron(3,3,3,2*nres))
19971       allocate(domicron(3,3,3,2*nres))
19972 !(3,3,3,maxres2)maxres2=2*maxres
19973 !----------------------
19974 ! common.var
19975 !      common /restr/
19976       allocate(varall(maxvar))
19977 !(maxvar)(maxvar=6*maxres)
19978       allocate(mask_theta(nres))
19979       allocate(mask_phi(nres))
19980       allocate(mask_side(nres))
19981 !(maxres)
19982 !----------------------
19983 ! common.vectors
19984 !      common /vectors/
19985       allocate(uy(3,nres))
19986       allocate(uz(3,nres))
19987 !(3,maxres)
19988       allocate(uygrad(3,3,2,nres))
19989       allocate(uzgrad(3,3,2,nres))
19990 !(3,3,2,maxres)
19991
19992       return
19993       end subroutine alloc_ener_arrays
19994 !-----------------------------------------------------------------
19995       subroutine ebond_nucl(estr_nucl)
19996 !c
19997 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
19998 !c
19999
20000       real(kind=8),dimension(3) :: u,ud
20001       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20002       real(kind=8) :: estr_nucl,diff
20003       integer :: iti,i,j,k,nbi
20004       estr_nucl=0.0d0
20005 !C      print *,"I enter ebond"
20006       if (energy_dec) &
20007       write (iout,*) "ibondp_start,ibondp_end",&
20008        ibondp_nucl_start,ibondp_nucl_end
20009       do i=ibondp_nucl_start,ibondp_nucl_end
20010         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20011          itype(i,2).eq.ntyp1_molec(2)) cycle
20012 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20013 !          do j=1,3
20014 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20015 !     &      *dc(j,i-1)/vbld(i)
20016 !          enddo
20017 !          if (energy_dec) write(iout,*)
20018 !     &       "estr1",i,vbld(i),distchainmax,
20019 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20020
20021           diff = vbld(i)-vbldp0_nucl
20022           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20023           vbldp0_nucl,diff,AKP_nucl*diff*diff
20024           estr_nucl=estr_nucl+diff*diff
20025 !          print *,estr_nucl
20026           do j=1,3
20027             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20028           enddo
20029 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20030       enddo
20031       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20032 !      print *,"partial sum", estr_nucl,AKP_nucl
20033
20034       if (energy_dec) &
20035       write (iout,*) "ibondp_start,ibondp_end",&
20036        ibond_nucl_start,ibond_nucl_end
20037
20038       do i=ibond_nucl_start,ibond_nucl_end
20039 !C        print *, "I am stuck",i
20040         iti=itype(i,2)
20041         if (iti.eq.ntyp1_molec(2)) cycle
20042           nbi=nbondterm_nucl(iti)
20043 !C        print *,iti,nbi
20044           if (nbi.eq.1) then
20045             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20046
20047             if (energy_dec) &
20048            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20049            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20050             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20051 !            print *,estr_nucl
20052             do j=1,3
20053               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20054             enddo
20055           else
20056             do j=1,nbi
20057               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20058               ud(j)=aksc_nucl(j,iti)*diff
20059               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20060             enddo
20061             uprod=u(1)
20062             do j=2,nbi
20063               uprod=uprod*u(j)
20064             enddo
20065             usum=0.0d0
20066             usumsqder=0.0d0
20067             do j=1,nbi
20068               uprod1=1.0d0
20069               uprod2=1.0d0
20070               do k=1,nbi
20071                 if (k.ne.j) then
20072                   uprod1=uprod1*u(k)
20073                   uprod2=uprod2*u(k)*u(k)
20074                 endif
20075               enddo
20076               usum=usum+uprod1
20077               usumsqder=usumsqder+ud(j)*uprod2
20078             enddo
20079             estr_nucl=estr_nucl+uprod/usum
20080             do j=1,3
20081              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20082             enddo
20083         endif
20084       enddo
20085 !C      print *,"I am about to leave ebond"
20086       return
20087       end subroutine ebond_nucl
20088
20089 !-----------------------------------------------------------------------------
20090       subroutine ebend_nucl(etheta_nucl)
20091       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20092       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20093       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20094       logical :: lprn=.false., lprn1=.false.
20095 !el local variables
20096       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20097       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20098       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20099 ! local variables for constrains
20100       real(kind=8) :: difi,thetiii
20101        integer itheta
20102       etheta_nucl=0.0D0
20103 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20104       do i=ithet_nucl_start,ithet_nucl_end
20105         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20106         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20107         (itype(i,2).eq.ntyp1_molec(2))) cycle
20108         dethetai=0.0d0
20109         dephii=0.0d0
20110         dephii1=0.0d0
20111         theti2=0.5d0*theta(i)
20112         ityp2=ithetyp_nucl(itype(i-1,2))
20113         do k=1,nntheterm_nucl
20114           coskt(k)=dcos(k*theti2)
20115           sinkt(k)=dsin(k*theti2)
20116         enddo
20117         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20118 #ifdef OSF
20119           phii=phi(i)
20120           if (phii.ne.phii) phii=150.0
20121 #else
20122           phii=phi(i)
20123 #endif
20124           ityp1=ithetyp_nucl(itype(i-2,2))
20125           do k=1,nsingle_nucl
20126             cosph1(k)=dcos(k*phii)
20127             sinph1(k)=dsin(k*phii)
20128           enddo
20129         else
20130           phii=0.0d0
20131           ityp1=nthetyp_nucl+1
20132           do k=1,nsingle_nucl
20133             cosph1(k)=0.0d0
20134             sinph1(k)=0.0d0
20135           enddo
20136         endif
20137
20138         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20139 #ifdef OSF
20140           phii1=phi(i+1)
20141           if (phii1.ne.phii1) phii1=150.0
20142           phii1=pinorm(phii1)
20143 #else
20144           phii1=phi(i+1)
20145 #endif
20146           ityp3=ithetyp_nucl(itype(i,2))
20147           do k=1,nsingle_nucl
20148             cosph2(k)=dcos(k*phii1)
20149             sinph2(k)=dsin(k*phii1)
20150           enddo
20151         else
20152           phii1=0.0d0
20153           ityp3=nthetyp_nucl+1
20154           do k=1,nsingle_nucl
20155             cosph2(k)=0.0d0
20156             sinph2(k)=0.0d0
20157           enddo
20158         endif
20159         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20160         do k=1,ndouble_nucl
20161           do l=1,k-1
20162             ccl=cosph1(l)*cosph2(k-l)
20163             ssl=sinph1(l)*sinph2(k-l)
20164             scl=sinph1(l)*cosph2(k-l)
20165             csl=cosph1(l)*sinph2(k-l)
20166             cosph1ph2(l,k)=ccl-ssl
20167             cosph1ph2(k,l)=ccl+ssl
20168             sinph1ph2(l,k)=scl+csl
20169             sinph1ph2(k,l)=scl-csl
20170           enddo
20171         enddo
20172         if (lprn) then
20173         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20174          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20175         write (iout,*) "coskt and sinkt",nntheterm_nucl
20176         do k=1,nntheterm_nucl
20177           write (iout,*) k,coskt(k),sinkt(k)
20178         enddo
20179         endif
20180         do k=1,ntheterm_nucl
20181           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20182           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20183            *coskt(k)
20184           if (lprn)&
20185          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20186           " ethetai",ethetai
20187         enddo
20188         if (lprn) then
20189         write (iout,*) "cosph and sinph"
20190         do k=1,nsingle_nucl
20191           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20192         enddo
20193         write (iout,*) "cosph1ph2 and sinph2ph2"
20194         do k=2,ndouble_nucl
20195           do l=1,k-1
20196             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20197               sinph1ph2(l,k),sinph1ph2(k,l)
20198           enddo
20199         enddo
20200         write(iout,*) "ethetai",ethetai
20201         endif
20202         do m=1,ntheterm2_nucl
20203           do k=1,nsingle_nucl
20204             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20205               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20206               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20207               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20208             ethetai=ethetai+sinkt(m)*aux
20209             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20210             dephii=dephii+k*sinkt(m)*(&
20211                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20212                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20213             dephii1=dephii1+k*sinkt(m)*(&
20214                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20215                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20216             if (lprn) &
20217            write (iout,*) "m",m," k",k," bbthet",&
20218               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20219               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20220               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20221               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20222           enddo
20223         enddo
20224         if (lprn) &
20225         write(iout,*) "ethetai",ethetai
20226         do m=1,ntheterm3_nucl
20227           do k=2,ndouble_nucl
20228             do l=1,k-1
20229               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20230                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20231                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20232                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20233               ethetai=ethetai+sinkt(m)*aux
20234               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20235               dephii=dephii+l*sinkt(m)*(&
20236                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20237                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20238                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20239                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20240               dephii1=dephii1+(k-l)*sinkt(m)*( &
20241                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20242                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20243                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20244                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20245               if (lprn) then
20246               write (iout,*) "m",m," k",k," l",l," ffthet", &
20247                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20248                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20249                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20250                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20251               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20252                  cosph1ph2(k,l)*sinkt(m),&
20253                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20254               endif
20255             enddo
20256           enddo
20257         enddo
20258 10      continue
20259         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20260         i,theta(i)*rad2deg,phii*rad2deg, &
20261         phii1*rad2deg,ethetai
20262         etheta_nucl=etheta_nucl+ethetai
20263 !        print *,i,"partial sum",etheta_nucl
20264         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20265         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20266         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20267       enddo
20268       return
20269       end subroutine ebend_nucl
20270 !----------------------------------------------------
20271       subroutine etor_nucl(etors_nucl)
20272 !      implicit real*8 (a-h,o-z)
20273 !      include 'DIMENSIONS'
20274 !      include 'COMMON.VAR'
20275 !      include 'COMMON.GEO'
20276 !      include 'COMMON.LOCAL'
20277 !      include 'COMMON.TORSION'
20278 !      include 'COMMON.INTERACT'
20279 !      include 'COMMON.DERIV'
20280 !      include 'COMMON.CHAIN'
20281 !      include 'COMMON.NAMES'
20282 !      include 'COMMON.IOUNITS'
20283 !      include 'COMMON.FFIELD'
20284 !      include 'COMMON.TORCNSTR'
20285 !      include 'COMMON.CONTROL'
20286       real(kind=8) :: etors_nucl,edihcnstr
20287       logical :: lprn
20288 !el local variables
20289       integer :: i,j,iblock,itori,itori1
20290       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20291                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20292 ! Set lprn=.true. for debugging
20293       lprn=.false.
20294 !     lprn=.true.
20295       etors_nucl=0.0D0
20296 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20297       do i=iphi_nucl_start,iphi_nucl_end
20298         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20299              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20300              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20301         etors_ii=0.0D0
20302         itori=itortyp_nucl(itype(i-2,2))
20303         itori1=itortyp_nucl(itype(i-1,2))
20304         phii=phi(i)
20305 !         print *,i,itori,itori1
20306         gloci=0.0D0
20307 !C Regular cosine and sine terms
20308         do j=1,nterm_nucl(itori,itori1)
20309           v1ij=v1_nucl(j,itori,itori1)
20310           v2ij=v2_nucl(j,itori,itori1)
20311           cosphi=dcos(j*phii)
20312           sinphi=dsin(j*phii)
20313           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20314           if (energy_dec) etors_ii=etors_ii+&
20315                      v1ij*cosphi+v2ij*sinphi
20316           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20317         enddo
20318 !C Lorentz terms
20319 !C                         v1
20320 !C  E = SUM ----------------------------------- - v1
20321 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20322 !C
20323         cosphi=dcos(0.5d0*phii)
20324         sinphi=dsin(0.5d0*phii)
20325         do j=1,nlor_nucl(itori,itori1)
20326           vl1ij=vlor1_nucl(j,itori,itori1)
20327           vl2ij=vlor2_nucl(j,itori,itori1)
20328           vl3ij=vlor3_nucl(j,itori,itori1)
20329           pom=vl2ij*cosphi+vl3ij*sinphi
20330           pom1=1.0d0/(pom*pom+1.0d0)
20331           etors_nucl=etors_nucl+vl1ij*pom1
20332           if (energy_dec) etors_ii=etors_ii+ &
20333                      vl1ij*pom1
20334           pom=-pom*pom1*pom1
20335           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20336         enddo
20337 !C Subtract the constant term
20338         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20339           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20340               'etor',i,etors_ii-v0_nucl(itori,itori1)
20341         if (lprn) &
20342        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20343        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20344        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20345         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20346 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20347       enddo
20348       return
20349       end subroutine etor_nucl
20350 !------------------------------------------------------------
20351       subroutine epp_nucl_sub(evdw1,ees)
20352 !C
20353 !C This subroutine calculates the average interaction energy and its gradient
20354 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20355 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20356 !C The potential depends both on the distance of peptide-group centers and on
20357 !C the orientation of the CA-CA virtual bonds.
20358 !C
20359       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20360       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20361       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20362                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20363                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20364       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20365                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20366       integer xshift,yshift,zshift
20367       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20368       real(kind=8) :: ees,eesij
20369 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20370       real(kind=8) scal_el /0.5d0/
20371       t_eelecij=0.0d0
20372       ees=0.0D0
20373       evdw1=0.0D0
20374       ind=0
20375 !c
20376 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20377 !c
20378 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20379       do i=iatel_s_nucl,iatel_e_nucl
20380         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20381         dxi=dc(1,i)
20382         dyi=dc(2,i)
20383         dzi=dc(3,i)
20384         dx_normi=dc_norm(1,i)
20385         dy_normi=dc_norm(2,i)
20386         dz_normi=dc_norm(3,i)
20387         xmedi=c(1,i)+0.5d0*dxi
20388         ymedi=c(2,i)+0.5d0*dyi
20389         zmedi=c(3,i)+0.5d0*dzi
20390           xmedi=dmod(xmedi,boxxsize)
20391           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20392           ymedi=dmod(ymedi,boxysize)
20393           if (ymedi.lt.0) ymedi=ymedi+boxysize
20394           zmedi=dmod(zmedi,boxzsize)
20395           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20396
20397         do j=ielstart_nucl(i),ielend_nucl(i)
20398           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20399           ind=ind+1
20400           dxj=dc(1,j)
20401           dyj=dc(2,j)
20402           dzj=dc(3,j)
20403 !          xj=c(1,j)+0.5D0*dxj-xmedi
20404 !          yj=c(2,j)+0.5D0*dyj-ymedi
20405 !          zj=c(3,j)+0.5D0*dzj-zmedi
20406           xj=c(1,j)+0.5D0*dxj
20407           yj=c(2,j)+0.5D0*dyj
20408           zj=c(3,j)+0.5D0*dzj
20409           xj=mod(xj,boxxsize)
20410           if (xj.lt.0) xj=xj+boxxsize
20411           yj=mod(yj,boxysize)
20412           if (yj.lt.0) yj=yj+boxysize
20413           zj=mod(zj,boxzsize)
20414           if (zj.lt.0) zj=zj+boxzsize
20415       isubchap=0
20416       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20417       xj_safe=xj
20418       yj_safe=yj
20419       zj_safe=zj
20420       do xshift=-1,1
20421       do yshift=-1,1
20422       do zshift=-1,1
20423           xj=xj_safe+xshift*boxxsize
20424           yj=yj_safe+yshift*boxysize
20425           zj=zj_safe+zshift*boxzsize
20426           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20427           if(dist_temp.lt.dist_init) then
20428             dist_init=dist_temp
20429             xj_temp=xj
20430             yj_temp=yj
20431             zj_temp=zj
20432             isubchap=1
20433           endif
20434        enddo
20435        enddo
20436        enddo
20437        if (isubchap.eq.1) then
20438 !C          print *,i,j
20439           xj=xj_temp-xmedi
20440           yj=yj_temp-ymedi
20441           zj=zj_temp-zmedi
20442        else
20443           xj=xj_safe-xmedi
20444           yj=yj_safe-ymedi
20445           zj=zj_safe-zmedi
20446        endif
20447
20448           rij=xj*xj+yj*yj+zj*zj
20449 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20450           fac=(r0pp**2/rij)**3
20451           ev1=epspp*fac*fac
20452           ev2=epspp*fac
20453           evdw1ij=ev1-2*ev2
20454           fac=(-ev1-evdw1ij)/rij
20455 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20456           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20457           evdw1=evdw1+evdw1ij
20458 !C
20459 !C Calculate contributions to the Cartesian gradient.
20460 !C
20461           ggg(1)=fac*xj
20462           ggg(2)=fac*yj
20463           ggg(3)=fac*zj
20464           do k=1,3
20465             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20466             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20467           enddo
20468 !c phoshate-phosphate electrostatic interactions
20469           rij=dsqrt(rij)
20470           fac=1.0d0/rij
20471           eesij=dexp(-BEES*rij)*fac
20472 !          write (2,*)"fac",fac," eesijpp",eesij
20473           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20474           ees=ees+eesij
20475 !c          fac=-eesij*fac
20476           fac=-(fac+BEES)*eesij*fac
20477           ggg(1)=fac*xj
20478           ggg(2)=fac*yj
20479           ggg(3)=fac*zj
20480 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20481 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20482 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20483           do k=1,3
20484             gelpp(k,i)=gelpp(k,i)-ggg(k)
20485             gelpp(k,j)=gelpp(k,j)+ggg(k)
20486           enddo
20487         enddo ! j
20488       enddo   ! i
20489 !c      ees=332.0d0*ees
20490       ees=AEES*ees
20491       do i=nnt,nct
20492 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20493         do k=1,3
20494           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20495 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20496           gelpp(k,i)=AEES*gelpp(k,i)
20497         enddo
20498 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20499       enddo
20500 !c      write (2,*) "total EES",ees
20501       return
20502       end subroutine epp_nucl_sub
20503 !---------------------------------------------------------------------
20504       subroutine epsb(evdwpsb,eelpsb)
20505 !      use comm_locel
20506 !C
20507 !C This subroutine calculates the excluded-volume interaction energy between
20508 !C peptide-group centers and side chains and its gradient in virtual-bond and
20509 !C side-chain vectors.
20510 !C
20511       real(kind=8),dimension(3):: ggg
20512       integer :: i,iint,j,k,iteli,itypj,subchap
20513       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20514                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20515       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20516                     dist_temp, dist_init
20517       integer xshift,yshift,zshift
20518
20519 !cd    print '(a)','Enter ESCP'
20520 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20521       eelpsb=0.0d0
20522       evdwpsb=0.0d0
20523 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20524       do i=iatscp_s_nucl,iatscp_e_nucl
20525         if (itype(i,2).eq.ntyp1_molec(2) &
20526          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20527         xi=0.5D0*(c(1,i)+c(1,i+1))
20528         yi=0.5D0*(c(2,i)+c(2,i+1))
20529         zi=0.5D0*(c(3,i)+c(3,i+1))
20530           xi=mod(xi,boxxsize)
20531           if (xi.lt.0) xi=xi+boxxsize
20532           yi=mod(yi,boxysize)
20533           if (yi.lt.0) yi=yi+boxysize
20534           zi=mod(zi,boxzsize)
20535           if (zi.lt.0) zi=zi+boxzsize
20536
20537         do iint=1,nscp_gr_nucl(i)
20538
20539         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20540           itypj=itype(j,2)
20541           if (itypj.eq.ntyp1_molec(2)) cycle
20542 !C Uncomment following three lines for SC-p interactions
20543 !c         xj=c(1,nres+j)-xi
20544 !c         yj=c(2,nres+j)-yi
20545 !c         zj=c(3,nres+j)-zi
20546 !C Uncomment following three lines for Ca-p interactions
20547 !          xj=c(1,j)-xi
20548 !          yj=c(2,j)-yi
20549 !          zj=c(3,j)-zi
20550           xj=c(1,j)
20551           yj=c(2,j)
20552           zj=c(3,j)
20553           xj=mod(xj,boxxsize)
20554           if (xj.lt.0) xj=xj+boxxsize
20555           yj=mod(yj,boxysize)
20556           if (yj.lt.0) yj=yj+boxysize
20557           zj=mod(zj,boxzsize)
20558           if (zj.lt.0) zj=zj+boxzsize
20559       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20560       xj_safe=xj
20561       yj_safe=yj
20562       zj_safe=zj
20563       subchap=0
20564       do xshift=-1,1
20565       do yshift=-1,1
20566       do zshift=-1,1
20567           xj=xj_safe+xshift*boxxsize
20568           yj=yj_safe+yshift*boxysize
20569           zj=zj_safe+zshift*boxzsize
20570           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20571           if(dist_temp.lt.dist_init) then
20572             dist_init=dist_temp
20573             xj_temp=xj
20574             yj_temp=yj
20575             zj_temp=zj
20576             subchap=1
20577           endif
20578        enddo
20579        enddo
20580        enddo
20581        if (subchap.eq.1) then
20582           xj=xj_temp-xi
20583           yj=yj_temp-yi
20584           zj=zj_temp-zi
20585        else
20586           xj=xj_safe-xi
20587           yj=yj_safe-yi
20588           zj=zj_safe-zi
20589        endif
20590
20591           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20592           fac=rrij**expon2
20593           e1=fac*fac*aad_nucl(itypj)
20594           e2=fac*bad_nucl(itypj)
20595           if (iabs(j-i) .le. 2) then
20596             e1=scal14*e1
20597             e2=scal14*e2
20598           endif
20599           evdwij=e1+e2
20600           evdwpsb=evdwpsb+evdwij
20601           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20602              'evdw2',i,j,evdwij,"tu4"
20603 !C
20604 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20605 !C
20606           fac=-(evdwij+e1)*rrij
20607           ggg(1)=xj*fac
20608           ggg(2)=yj*fac
20609           ggg(3)=zj*fac
20610           do k=1,3
20611             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20612             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20613           enddo
20614         enddo
20615
20616         enddo ! iint
20617       enddo ! i
20618       do i=1,nct
20619         do j=1,3
20620           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20621           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20622         enddo
20623       enddo
20624       return
20625       end subroutine epsb
20626
20627 !------------------------------------------------------
20628       subroutine esb_gb(evdwsb,eelsb)
20629       use comm_locel
20630       use calc_data_nucl
20631       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20632       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20633       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20634       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20635                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20636       integer :: ii
20637       logical lprn
20638       evdw=0.0D0
20639       eelsb=0.0d0
20640       ecorr=0.0d0
20641       evdwsb=0.0D0
20642       lprn=.false.
20643       ind=0
20644 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20645       do i=iatsc_s_nucl,iatsc_e_nucl
20646         num_conti=0
20647         num_conti2=0
20648         itypi=itype(i,2)
20649 !        PRINT *,"I=",i,itypi
20650         if (itypi.eq.ntyp1_molec(2)) cycle
20651         itypi1=itype(i+1,2)
20652         xi=c(1,nres+i)
20653         yi=c(2,nres+i)
20654         zi=c(3,nres+i)
20655           xi=dmod(xi,boxxsize)
20656           if (xi.lt.0) xi=xi+boxxsize
20657           yi=dmod(yi,boxysize)
20658           if (yi.lt.0) yi=yi+boxysize
20659           zi=dmod(zi,boxzsize)
20660           if (zi.lt.0) zi=zi+boxzsize
20661
20662         dxi=dc_norm(1,nres+i)
20663         dyi=dc_norm(2,nres+i)
20664         dzi=dc_norm(3,nres+i)
20665         dsci_inv=vbld_inv(i+nres)
20666 !C
20667 !C Calculate SC interaction energy.
20668 !C
20669         do iint=1,nint_gr_nucl(i)
20670 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20671           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20672             ind=ind+1
20673 !            print *,"JESTEM"
20674             itypj=itype(j,2)
20675             if (itypj.eq.ntyp1_molec(2)) cycle
20676             dscj_inv=vbld_inv(j+nres)
20677             sig0ij=sigma_nucl(itypi,itypj)
20678             chi1=chi_nucl(itypi,itypj)
20679             chi2=chi_nucl(itypj,itypi)
20680             chi12=chi1*chi2
20681             chip1=chip_nucl(itypi,itypj)
20682             chip2=chip_nucl(itypj,itypi)
20683             chip12=chip1*chip2
20684 !            xj=c(1,nres+j)-xi
20685 !            yj=c(2,nres+j)-yi
20686 !            zj=c(3,nres+j)-zi
20687            xj=c(1,nres+j)
20688            yj=c(2,nres+j)
20689            zj=c(3,nres+j)
20690           xj=dmod(xj,boxxsize)
20691           if (xj.lt.0) xj=xj+boxxsize
20692           yj=dmod(yj,boxysize)
20693           if (yj.lt.0) yj=yj+boxysize
20694           zj=dmod(zj,boxzsize)
20695           if (zj.lt.0) zj=zj+boxzsize
20696       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20697       xj_safe=xj
20698       yj_safe=yj
20699       zj_safe=zj
20700       subchap=0
20701       do xshift=-1,1
20702       do yshift=-1,1
20703       do zshift=-1,1
20704           xj=xj_safe+xshift*boxxsize
20705           yj=yj_safe+yshift*boxysize
20706           zj=zj_safe+zshift*boxzsize
20707           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20708           if(dist_temp.lt.dist_init) then
20709             dist_init=dist_temp
20710             xj_temp=xj
20711             yj_temp=yj
20712             zj_temp=zj
20713             subchap=1
20714           endif
20715        enddo
20716        enddo
20717        enddo
20718        if (subchap.eq.1) then
20719           xj=xj_temp-xi
20720           yj=yj_temp-yi
20721           zj=zj_temp-zi
20722        else
20723           xj=xj_safe-xi
20724           yj=yj_safe-yi
20725           zj=zj_safe-zi
20726        endif
20727
20728             dxj=dc_norm(1,nres+j)
20729             dyj=dc_norm(2,nres+j)
20730             dzj=dc_norm(3,nres+j)
20731             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20732             rij=dsqrt(rrij)
20733 !C Calculate angle-dependent terms of energy and contributions to their
20734 !C derivatives.
20735             erij(1)=xj*rij
20736             erij(2)=yj*rij
20737             erij(3)=zj*rij
20738             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20739             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20740             om12=dxi*dxj+dyi*dyj+dzi*dzj
20741             call sc_angular_nucl
20742             sigsq=1.0D0/sigsq
20743             sig=sig0ij*dsqrt(sigsq)
20744             rij_shift=1.0D0/rij-sig+sig0ij
20745 !            print *,rij_shift,"rij_shift"
20746 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20747 !c     &       " rij_shift",rij_shift
20748             if (rij_shift.le.0.0D0) then
20749               evdw=1.0D20
20750               return
20751             endif
20752             sigder=-sig*sigsq
20753 !c---------------------------------------------------------------
20754             rij_shift=1.0D0/rij_shift
20755             fac=rij_shift**expon
20756             e1=fac*fac*aa_nucl(itypi,itypj)
20757             e2=fac*bb_nucl(itypi,itypj)
20758             evdwij=eps1*eps2rt*(e1+e2)
20759 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20760 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20761             eps2der=evdwij
20762             evdwij=evdwij*eps2rt
20763             evdwsb=evdwsb+evdwij
20764             if (lprn) then
20765             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
20766             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
20767             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20768              restyp(itypi,2),i,restyp(itypj,2),j, &
20769              epsi,sigm,chi1,chi2,chip1,chip2, &
20770              eps1,eps2rt**2,sig,sig0ij, &
20771              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20772             evdwij
20773             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20774             endif
20775
20776             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20777                              'evdw',i,j,evdwij,"tu3"
20778
20779
20780 !C Calculate gradient components.
20781             e1=e1*eps1*eps2rt**2
20782             fac=-expon*(e1+evdwij)*rij_shift
20783             sigder=fac*sigder
20784             fac=rij*fac
20785 !c            fac=0.0d0
20786 !C Calculate the radial part of the gradient
20787             gg(1)=xj*fac
20788             gg(2)=yj*fac
20789             gg(3)=zj*fac
20790 !C Calculate angular part of the gradient.
20791             call sc_grad_nucl
20792             call eelsbij(eelij,num_conti2)
20793             if (energy_dec .and. &
20794            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20795           write (istat,'(e14.5)') evdwij
20796             eelsb=eelsb+eelij
20797           enddo      ! j
20798         enddo        ! iint
20799         num_cont_hb(i)=num_conti2
20800       enddo          ! i
20801 !c      write (iout,*) "Number of loop steps in EGB:",ind
20802 !cccc      energy_dec=.false.
20803       return
20804       end subroutine esb_gb
20805 !-------------------------------------------------------------------------------
20806       subroutine eelsbij(eesij,num_conti2)
20807       use comm_locel
20808       use calc_data_nucl
20809       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20810       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20811       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20812                     dist_temp, dist_init,rlocshield,fracinbuf
20813       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20814
20815 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20816       real(kind=8) scal_el /0.5d0/
20817       integer :: iteli,itelj,kkk,kkll,m,isubchap
20818       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20819       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20820       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20821                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20822                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20823                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20824                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20825                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20826                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20827                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20828       ind=ind+1
20829       itypi=itype(i,2)
20830       itypj=itype(j,2)
20831 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20832       ael6i=ael6_nucl(itypi,itypj)
20833       ael3i=ael3_nucl(itypi,itypj)
20834       ael63i=ael63_nucl(itypi,itypj)
20835       ael32i=ael32_nucl(itypi,itypj)
20836 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20837 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20838       dxj=dc(1,j+nres)
20839       dyj=dc(2,j+nres)
20840       dzj=dc(3,j+nres)
20841       dx_normi=dc_norm(1,i+nres)
20842       dy_normi=dc_norm(2,i+nres)
20843       dz_normi=dc_norm(3,i+nres)
20844       dx_normj=dc_norm(1,j+nres)
20845       dy_normj=dc_norm(2,j+nres)
20846       dz_normj=dc_norm(3,j+nres)
20847 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20848 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20849 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20850       if (ipot_nucl.ne.2) then
20851         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20852         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20853         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20854       else
20855         cosa=om12
20856         cosb=om1
20857         cosg=om2
20858       endif
20859       r3ij=rij*rrij
20860       r6ij=r3ij*r3ij
20861       fac=cosa-3.0D0*cosb*cosg
20862       facfac=fac*fac
20863       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20864       fac3=ael6i*r6ij
20865       fac4=ael3i*r3ij
20866       fac5=ael63i*r6ij
20867       fac6=ael32i*r6ij
20868 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20869 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20870       el1=fac3*(4.0D0+facfac-fac1)
20871       el2=fac4*fac
20872       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20873       el4=fac6*facfac
20874       eesij=el1+el2+el3+el4
20875 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20876       ees0ij=4.0D0+facfac-fac1
20877
20878       if (energy_dec) then
20879           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20880           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20881            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20882            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20883            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20884           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20885       endif
20886
20887 !C
20888 !C Calculate contributions to the Cartesian gradient.
20889 !C
20890       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20891       fac1=fac
20892 !c      erij(1)=xj*rmij
20893 !c      erij(2)=yj*rmij
20894 !c      erij(3)=zj*rmij
20895 !*
20896 !* Radial derivatives. First process both termini of the fragment (i,j)
20897 !*
20898       ggg(1)=facel*xj
20899       ggg(2)=facel*yj
20900       ggg(3)=facel*zj
20901       do k=1,3
20902         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20903         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20904         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20905         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20906       enddo
20907 !*
20908 !* Angular part
20909 !*
20910       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20911       fac4=-3.0D0*fac4
20912       fac3=-6.0D0*fac3
20913       fac5= 6.0d0*fac5
20914       fac6=-6.0d0*fac6
20915       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20916        fac6*fac1*cosg
20917       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20918        fac6*fac1*cosb
20919       do k=1,3
20920         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20921         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20922       enddo
20923       do k=1,3
20924         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20925       enddo
20926       do k=1,3
20927         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20928              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20929              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20930         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20931              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20932              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20933         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20934         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20935       enddo
20936 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
20937        IF ( j.gt.i+1 .and.&
20938           num_conti.le.maxconts) THEN
20939 !C
20940 !C Calculate the contact function. The ith column of the array JCONT will
20941 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20942 !C greater than I). The arrays FACONT and GACONT will contain the values of
20943 !C the contact function and its derivative.
20944         r0ij=2.20D0*sigma(itypi,itypj)
20945 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20946         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20947 !c        write (2,*) "fcont",fcont
20948         if (fcont.gt.0.0D0) then
20949           num_conti=num_conti+1
20950           num_conti2=num_conti2+1
20951
20952           if (num_conti.gt.maxconts) then
20953             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20954                           ' will skip next contacts for this conf.'
20955           else
20956             jcont_hb(num_conti,i)=j
20957 !c            write (iout,*) "num_conti",num_conti,
20958 !c     &        " jcont_hb",jcont_hb(num_conti,i)
20959 !C Calculate contact energies
20960             cosa4=4.0D0*cosa
20961             wij=cosa-3.0D0*cosb*cosg
20962             cosbg1=cosb+cosg
20963             cosbg2=cosb-cosg
20964             fac3=dsqrt(-ael6i)*r3ij
20965 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
20966             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
20967             if (ees0tmp.gt.0) then
20968               ees0pij=dsqrt(ees0tmp)
20969             else
20970               ees0pij=0
20971             endif
20972             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
20973             if (ees0tmp.gt.0) then
20974               ees0mij=dsqrt(ees0tmp)
20975             else
20976               ees0mij=0
20977             endif
20978             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
20979             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
20980 !c            write (iout,*) "i",i," j",j,
20981 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
20982             ees0pij1=fac3/ees0pij
20983             ees0mij1=fac3/ees0mij
20984             fac3p=-3.0D0*fac3*rrij
20985             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
20986             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
20987             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
20988             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
20989             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
20990             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
20991             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
20992             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
20993             ecosap=ecosa1+ecosa2
20994             ecosbp=ecosb1+ecosb2
20995             ecosgp=ecosg1+ecosg2
20996             ecosam=ecosa1-ecosa2
20997             ecosbm=ecosb1-ecosb2
20998             ecosgm=ecosg1-ecosg2
20999 !C End diagnostics
21000             facont_hb(num_conti,i)=fcont
21001             fprimcont=fprimcont/rij
21002             do k=1,3
21003               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21004               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21005             enddo
21006             gggp(1)=gggp(1)+ees0pijp*xj
21007             gggp(2)=gggp(2)+ees0pijp*yj
21008             gggp(3)=gggp(3)+ees0pijp*zj
21009             gggm(1)=gggm(1)+ees0mijp*xj
21010             gggm(2)=gggm(2)+ees0mijp*yj
21011             gggm(3)=gggm(3)+ees0mijp*zj
21012 !C Derivatives due to the contact function
21013             gacont_hbr(1,num_conti,i)=fprimcont*xj
21014             gacont_hbr(2,num_conti,i)=fprimcont*yj
21015             gacont_hbr(3,num_conti,i)=fprimcont*zj
21016             do k=1,3
21017 !c
21018 !c Gradient of the correlation terms
21019 !c
21020               gacontp_hb1(k,num_conti,i)= &
21021              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21022             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21023               gacontp_hb2(k,num_conti,i)= &
21024              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21025             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21026               gacontp_hb3(k,num_conti,i)=gggp(k)
21027               gacontm_hb1(k,num_conti,i)= &
21028              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21029             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21030               gacontm_hb2(k,num_conti,i)= &
21031              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21032             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21033               gacontm_hb3(k,num_conti,i)=gggm(k)
21034             enddo
21035           endif
21036         endif
21037       ENDIF
21038       return
21039       end subroutine eelsbij
21040 !------------------------------------------------------------------
21041       subroutine sc_grad_nucl
21042       use comm_locel
21043       use calc_data_nucl
21044       real(kind=8),dimension(3) :: dcosom1,dcosom2
21045       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21046       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21047       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21048       do k=1,3
21049         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21050         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21051       enddo
21052       do k=1,3
21053         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21054       enddo
21055       do k=1,3
21056         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21057                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21058                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21059         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21060                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21061                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21062       enddo
21063 !C
21064 !C Calculate the components of the gradient in DC and X
21065 !C
21066       do l=1,3
21067         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21068         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21069       enddo
21070       return
21071       end subroutine sc_grad_nucl
21072 !-----------------------------------------------------------------------
21073       subroutine esb(esbloc)
21074 !C Calculate the local energy of a side chain and its derivatives in the
21075 !C corresponding virtual-bond valence angles THETA and the spherical angles
21076 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21077 !C added by Urszula Kozlowska. 07/11/2007
21078 !C
21079       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21080       real(kind=8),dimension(9):: x
21081      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21082       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21083       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21084       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21085        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21086        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21087        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21088        integer::it,nlobit,i,j,k
21089 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21090       delta=0.02d0*pi
21091       esbloc=0.0D0
21092       do i=loc_start_nucl,loc_end_nucl
21093         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21094         costtab(i+1) =dcos(theta(i+1))
21095         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21096         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21097         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21098         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21099         cosfac=dsqrt(cosfac2)
21100         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21101         sinfac=dsqrt(sinfac2)
21102         it=itype(i,2)
21103         if (it.eq.10) goto 1
21104
21105 !c
21106 !C  Compute the axes of tghe local cartesian coordinates system; store in
21107 !c   x_prime, y_prime and z_prime
21108 !c
21109         do j=1,3
21110           x_prime(j) = 0.00
21111           y_prime(j) = 0.00
21112           z_prime(j) = 0.00
21113         enddo
21114 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21115 !C     &   dc_norm(3,i+nres)
21116         do j = 1,3
21117           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21118           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21119         enddo
21120         do j = 1,3
21121           z_prime(j) = -uz(j,i-1)
21122 !           z_prime(j)=0.0
21123         enddo
21124
21125         xx=0.0d0
21126         yy=0.0d0
21127         zz=0.0d0
21128         do j = 1,3
21129           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21130           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21131           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21132         enddo
21133
21134         xxtab(i)=xx
21135         yytab(i)=yy
21136         zztab(i)=zz
21137          it=itype(i,2)
21138         do j = 1,9
21139           x(j) = sc_parmin_nucl(j,it)
21140         enddo
21141 #ifdef CHECK_COORD
21142 !Cc diagnostics - remove later
21143         xx1 = dcos(alph(2))
21144         yy1 = dsin(alph(2))*dcos(omeg(2))
21145         zz1 = -dsin(alph(2))*dsin(omeg(2))
21146         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21147          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21148          xx1,yy1,zz1
21149 !C,"  --- ", xx_w,yy_w,zz_w
21150 !c end diagnostics
21151 #endif
21152         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21153         esbloc = esbloc + sumene
21154         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21155 !        print *,"enecomp",sumene,sumene2
21156 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21157 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21158 #ifdef DEBUG
21159         write (2,*) "x",(x(k),k=1,9)
21160 !C
21161 !C This section to check the numerical derivatives of the energy of ith side
21162 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21163 !C #define DEBUG in the code to turn it on.
21164 !C
21165         write (2,*) "sumene               =",sumene
21166         aincr=1.0d-7
21167         xxsave=xx
21168         xx=xx+aincr
21169         write (2,*) xx,yy,zz
21170         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21171         de_dxx_num=(sumenep-sumene)/aincr
21172         xx=xxsave
21173         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21174         yysave=yy
21175         yy=yy+aincr
21176         write (2,*) xx,yy,zz
21177         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21178         de_dyy_num=(sumenep-sumene)/aincr
21179         yy=yysave
21180         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21181         zzsave=zz
21182         zz=zz+aincr
21183         write (2,*) xx,yy,zz
21184         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21185         de_dzz_num=(sumenep-sumene)/aincr
21186         zz=zzsave
21187         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21188         costsave=cost2tab(i+1)
21189         sintsave=sint2tab(i+1)
21190         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21191         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21192         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21193         de_dt_num=(sumenep-sumene)/aincr
21194         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21195         cost2tab(i+1)=costsave
21196         sint2tab(i+1)=sintsave
21197 !C End of diagnostics section.
21198 #endif
21199 !C
21200 !C Compute the gradient of esc
21201 !C
21202         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21203         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21204         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21205         de_dtt=0.0d0
21206 #ifdef DEBUG
21207         write (2,*) "x",(x(k),k=1,9)
21208         write (2,*) "xx",xx," yy",yy," zz",zz
21209         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21210           " de_zz   ",de_zz," de_tt   ",de_tt
21211         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21212           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21213 #endif
21214 !C
21215        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21216        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21217        cosfac2xx=cosfac2*xx
21218        sinfac2yy=sinfac2*yy
21219        do k = 1,3
21220          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21221            vbld_inv(i+1)
21222          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21223            vbld_inv(i)
21224          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21225          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21226 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21227 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21228 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21229 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21230          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21231          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21232          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21233          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21234          dZZ_Ci1(k)=0.0d0
21235          dZZ_Ci(k)=0.0d0
21236          do j=1,3
21237            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21238            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21239          enddo
21240
21241          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21242          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21243          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21244 !c
21245          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21246          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21247        enddo
21248
21249        do k=1,3
21250          dXX_Ctab(k,i)=dXX_Ci(k)
21251          dXX_C1tab(k,i)=dXX_Ci1(k)
21252          dYY_Ctab(k,i)=dYY_Ci(k)
21253          dYY_C1tab(k,i)=dYY_Ci1(k)
21254          dZZ_Ctab(k,i)=dZZ_Ci(k)
21255          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21256          dXX_XYZtab(k,i)=dXX_XYZ(k)
21257          dYY_XYZtab(k,i)=dYY_XYZ(k)
21258          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21259        enddo
21260        do k = 1,3
21261 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21262 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21263 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21264 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21265 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21266 !c     &    dt_dci(k)
21267 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21268 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21269          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21270          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21271          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21272          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21273          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21274          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21275 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21276        enddo
21277 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21278 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21279
21280 !C to check gradient call subroutine check_grad
21281
21282     1 continue
21283       enddo
21284       return
21285       end subroutine esb
21286 !=-------------------------------------------------------
21287       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21288 !      implicit none
21289       real(kind=8),dimension(9):: x(9)
21290        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21291       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21292       integer i
21293 !c      write (2,*) "enesc"
21294 !c      write (2,*) "x",(x(i),i=1,9)
21295 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21296       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21297         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21298         + x(9)*yy*zz
21299       enesc_nucl=sumene
21300       return
21301       end function enesc_nucl
21302 !-----------------------------------------------------------------------------
21303       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21304 #ifdef MPI
21305       include 'mpif.h'
21306       integer,parameter :: max_cont=2000
21307       integer,parameter:: max_dim=2*(8*3+6)
21308       integer, parameter :: msglen1=max_cont*max_dim
21309       integer,parameter :: msglen2=2*msglen1
21310       integer source,CorrelType,CorrelID,Error
21311       real(kind=8) :: buffer(max_cont,max_dim)
21312       integer status(MPI_STATUS_SIZE)
21313       integer :: ierror,nbytes
21314 #endif
21315       real(kind=8),dimension(3):: gx(3),gx1(3)
21316       real(kind=8) :: time00
21317       logical lprn,ldone
21318       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21319       real(kind=8) ecorr,ecorr3
21320       integer :: n_corr,n_corr1,mm,msglen
21321 !C Set lprn=.true. for debugging
21322       lprn=.false.
21323       n_corr=0
21324       n_corr1=0
21325 #ifdef MPI
21326       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21327
21328       if (nfgtasks.le.1) goto 30
21329       if (lprn) then
21330         write (iout,'(a)') 'Contact function values:'
21331         do i=nnt,nct-1
21332           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21333          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21334          j=1,num_cont_hb(i))
21335         enddo
21336       endif
21337 !C Caution! Following code assumes that electrostatic interactions concerning
21338 !C a given atom are split among at most two processors!
21339       CorrelType=477
21340       CorrelID=fg_rank+1
21341       ldone=.false.
21342       do i=1,max_cont
21343         do j=1,max_dim
21344           buffer(i,j)=0.0D0
21345         enddo
21346       enddo
21347       mm=mod(fg_rank,2)
21348 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21349       if (mm) 20,20,10
21350    10 continue
21351 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21352       if (fg_rank.gt.0) then
21353 !C Send correlation contributions to the preceding processor
21354         msglen=msglen1
21355         nn=num_cont_hb(iatel_s_nucl)
21356         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21357 !c        write (*,*) 'The BUFFER array:'
21358 !c        do i=1,nn
21359 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21360 !c        enddo
21361         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21362           msglen=msglen2
21363           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21364 !C Clear the contacts of the atom passed to the neighboring processor
21365         nn=num_cont_hb(iatel_s_nucl+1)
21366 !c        do i=1,nn
21367 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21368 !c        enddo
21369             num_cont_hb(iatel_s_nucl)=0
21370         endif
21371 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21372 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21373 !cd   & ' msglen=',msglen
21374 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21375 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21376 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21377         time00=MPI_Wtime()
21378         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21379          CorrelType,FG_COMM,IERROR)
21380         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21381 !cd      write (iout,*) 'Processor ',fg_rank,
21382 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21383 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21384 !c        write (*,*) 'Processor ',fg_rank,
21385 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21386 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21387 !c        msglen=msglen1
21388       endif ! (fg_rank.gt.0)
21389       if (ldone) goto 30
21390       ldone=.true.
21391    20 continue
21392 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21393       if (fg_rank.lt.nfgtasks-1) then
21394 !C Receive correlation contributions from the next processor
21395         msglen=msglen1
21396         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21397 !cd      write (iout,*) 'Processor',fg_rank,
21398 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21399 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21400 !c        write (*,*) 'Processor',fg_rank,
21401 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21402 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21403         time00=MPI_Wtime()
21404         nbytes=-1
21405         do while (nbytes.le.0)
21406           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21407           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21408         enddo
21409 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21410         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21411          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21412         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21413 !c        write (*,*) 'Processor',fg_rank,
21414 !c     &' has received correlation contribution from processor',fg_rank+1,
21415 !c     & ' msglen=',msglen,' nbytes=',nbytes
21416 !c        write (*,*) 'The received BUFFER array:'
21417 !c        do i=1,max_cont
21418 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21419 !c        enddo
21420         if (msglen.eq.msglen1) then
21421           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21422         else if (msglen.eq.msglen2)  then
21423           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21424           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21425         else
21426           write (iout,*) &
21427       'ERROR!!!! message length changed while processing correlations.'
21428           write (*,*) &
21429       'ERROR!!!! message length changed while processing correlations.'
21430           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21431         endif ! msglen.eq.msglen1
21432       endif ! fg_rank.lt.nfgtasks-1
21433       if (ldone) goto 30
21434       ldone=.true.
21435       goto 10
21436    30 continue
21437 #endif
21438       if (lprn) then
21439         write (iout,'(a)') 'Contact function values:'
21440         do i=nnt_molec(2),nct_molec(2)-1
21441           write (iout,'(2i3,50(1x,i2,f5.2))') &
21442          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21443          j=1,num_cont_hb(i))
21444         enddo
21445       endif
21446       ecorr=0.0D0
21447       ecorr3=0.0d0
21448 !C Remove the loop below after debugging !!!
21449 !      do i=nnt_molec(2),nct_molec(2)
21450 !        do j=1,3
21451 !          gradcorr_nucl(j,i)=0.0D0
21452 !          gradxorr_nucl(j,i)=0.0D0
21453 !          gradcorr3_nucl(j,i)=0.0D0
21454 !          gradxorr3_nucl(j,i)=0.0D0
21455 !        enddo
21456 !      enddo
21457 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21458 !C Calculate the local-electrostatic correlation terms
21459       do i=iatsc_s_nucl,iatsc_e_nucl
21460         i1=i+1
21461         num_conti=num_cont_hb(i)
21462         num_conti1=num_cont_hb(i+1)
21463 !        print *,i,num_conti,num_conti1
21464         do jj=1,num_conti
21465           j=jcont_hb(jj,i)
21466           do kk=1,num_conti1
21467             j1=jcont_hb(kk,i1)
21468 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21469 !c     &         ' jj=',jj,' kk=',kk
21470             if (j1.eq.j+1 .or. j1.eq.j-1) then
21471 !C
21472 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21473 !C The system gains extra energy.
21474 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21475 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21476 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21477 !C
21478               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21479               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21480                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21481               n_corr=n_corr+1
21482             else if (j1.eq.j) then
21483 !C
21484 !C Contacts I-J and I-(J+1) occur simultaneously.
21485 !C The system loses extra energy.
21486 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21487 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21488 !C Need to implement full formulas 32 from Liwo et al., 1998.
21489 !C
21490 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21491 !c     &         ' jj=',jj,' kk=',kk
21492               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21493             endif
21494           enddo ! kk
21495           do kk=1,num_conti
21496             j1=jcont_hb(kk,i)
21497 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21498 !c     &         ' jj=',jj,' kk=',kk
21499             if (j1.eq.j+1) then
21500 !C Contacts I-J and (I+1)-J occur simultaneously.
21501 !C The system loses extra energy.
21502               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21503             endif ! j1==j+1
21504           enddo ! kk
21505         enddo ! jj
21506       enddo ! i
21507       return
21508       end subroutine multibody_hb_nucl
21509 !-----------------------------------------------------------
21510       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21511 !      implicit real*8 (a-h,o-z)
21512 !      include 'DIMENSIONS'
21513 !      include 'COMMON.IOUNITS'
21514 !      include 'COMMON.DERIV'
21515 !      include 'COMMON.INTERACT'
21516 !      include 'COMMON.CONTACTS'
21517       real(kind=8),dimension(3) :: gx,gx1
21518       logical :: lprn
21519 !el local variables
21520       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21521       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21522                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21523                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21524                    rlocshield
21525
21526       lprn=.false.
21527       eij=facont_hb(jj,i)
21528       ekl=facont_hb(kk,k)
21529       ees0pij=ees0p(jj,i)
21530       ees0pkl=ees0p(kk,k)
21531       ees0mij=ees0m(jj,i)
21532       ees0mkl=ees0m(kk,k)
21533       ekont=eij*ekl
21534       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21535 !      print *,"ehbcorr_nucl",ekont,ees
21536 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21537 !C Following 4 lines for diagnostics.
21538 !cd    ees0pkl=0.0D0
21539 !cd    ees0pij=1.0D0
21540 !cd    ees0mkl=0.0D0
21541 !cd    ees0mij=1.0D0
21542 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21543 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21544 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21545 !C Calculate the multi-body contribution to energy.
21546 !      ecorr_nucl=ecorr_nucl+ekont*ees
21547 !C Calculate multi-body contributions to the gradient.
21548       coeffpees0pij=coeffp*ees0pij
21549       coeffmees0mij=coeffm*ees0mij
21550       coeffpees0pkl=coeffp*ees0pkl
21551       coeffmees0mkl=coeffm*ees0mkl
21552       do ll=1,3
21553         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21554        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21555        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21556         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21557         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21558         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21559         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21560         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21561         coeffmees0mij*gacontm_hb1(ll,kk,k))
21562         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21563         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21564         coeffmees0mij*gacontm_hb2(ll,kk,k))
21565         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21566           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21567           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21568         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21569         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21570         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21571           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21572           coeffmees0mij*gacontm_hb3(ll,kk,k))
21573         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21574         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21575         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21576         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21577         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21578         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21579       enddo
21580       ehbcorr_nucl=ekont*ees
21581       return
21582       end function ehbcorr_nucl
21583 !-------------------------------------------------------------------------
21584
21585      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21586 !      implicit real*8 (a-h,o-z)
21587 !      include 'DIMENSIONS'
21588 !      include 'COMMON.IOUNITS'
21589 !      include 'COMMON.DERIV'
21590 !      include 'COMMON.INTERACT'
21591 !      include 'COMMON.CONTACTS'
21592       real(kind=8),dimension(3) :: gx,gx1
21593       logical :: lprn
21594 !el local variables
21595       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21596       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21597                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21598                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21599                    rlocshield
21600
21601       lprn=.false.
21602       eij=facont_hb(jj,i)
21603       ekl=facont_hb(kk,k)
21604       ees0pij=ees0p(jj,i)
21605       ees0pkl=ees0p(kk,k)
21606       ees0mij=ees0m(jj,i)
21607       ees0mkl=ees0m(kk,k)
21608       ekont=eij*ekl
21609       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21610 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21611 !C Following 4 lines for diagnostics.
21612 !cd    ees0pkl=0.0D0
21613 !cd    ees0pij=1.0D0
21614 !cd    ees0mkl=0.0D0
21615 !cd    ees0mij=1.0D0
21616 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21617 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21618 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21619 !C Calculate the multi-body contribution to energy.
21620 !      ecorr=ecorr+ekont*ees
21621 !C Calculate multi-body contributions to the gradient.
21622       coeffpees0pij=coeffp*ees0pij
21623       coeffmees0mij=coeffm*ees0mij
21624       coeffpees0pkl=coeffp*ees0pkl
21625       coeffmees0mkl=coeffm*ees0mkl
21626       do ll=1,3
21627         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21628        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21629        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21630         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21631         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21632         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21633         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21634         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21635         coeffmees0mij*gacontm_hb1(ll,kk,k))
21636         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21637         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21638         coeffmees0mij*gacontm_hb2(ll,kk,k))
21639         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21640           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21641           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21642         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21643         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21644         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21645           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21646           coeffmees0mij*gacontm_hb3(ll,kk,k))
21647         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21648         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21649         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21650         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21651         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21652         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21653       enddo
21654       ehbcorr3_nucl=ekont*ees
21655       return
21656       end function ehbcorr3_nucl
21657 #ifdef MPI
21658       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21659       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21660       real(kind=8):: buffer(dimen1,dimen2)
21661       num_kont=num_cont_hb(atom)
21662       do i=1,num_kont
21663         do k=1,8
21664           do j=1,3
21665             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21666           enddo ! j
21667         enddo ! k
21668         buffer(i,indx+25)=facont_hb(i,atom)
21669         buffer(i,indx+26)=ees0p(i,atom)
21670         buffer(i,indx+27)=ees0m(i,atom)
21671         buffer(i,indx+28)=d_cont(i,atom)
21672         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21673       enddo ! i
21674       buffer(1,indx+30)=dfloat(num_kont)
21675       return
21676       end subroutine pack_buffer
21677 !c------------------------------------------------------------------------------
21678       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21679       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21680       real(kind=8):: buffer(dimen1,dimen2)
21681 !      double precision zapas
21682 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21683 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21684 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21685 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21686       num_kont=buffer(1,indx+30)
21687       num_kont_old=num_cont_hb(atom)
21688       num_cont_hb(atom)=num_kont+num_kont_old
21689       do i=1,num_kont
21690         ii=i+num_kont_old
21691         do k=1,8
21692           do j=1,3
21693             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21694           enddo ! j
21695         enddo ! k
21696         facont_hb(ii,atom)=buffer(i,indx+25)
21697         ees0p(ii,atom)=buffer(i,indx+26)
21698         ees0m(ii,atom)=buffer(i,indx+27)
21699         d_cont(i,atom)=buffer(i,indx+28)
21700         jcont_hb(ii,atom)=buffer(i,indx+29)
21701       enddo ! i
21702       return
21703       end subroutine unpack_buffer
21704 !c------------------------------------------------------------------------------
21705 #endif
21706       subroutine ecatcat(ecationcation)
21707         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21708         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21709         r7,r4,ecationcation,k0,rcal
21710         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21711         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21712         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21713         gg,r
21714
21715         ecationcation=0.0d0
21716         if (nres_molec(5).eq.0) return
21717         rcat0=3.472
21718         epscalc=0.05
21719         r06 = rcat0**6
21720         r012 = r06**2
21721         k0 = 332.0*(2.0*2.0)/80.0
21722         itmp=0
21723
21724         do i=1,4
21725         itmp=itmp+nres_molec(i)
21726         enddo
21727 !        write(iout,*) "itmp",itmp
21728         do i=itmp+1,itmp+nres_molec(5)-1
21729
21730         xi=c(1,i)
21731         yi=c(2,i)
21732         zi=c(3,i)
21733
21734           xi=mod(xi,boxxsize)
21735           if (xi.lt.0) xi=xi+boxxsize
21736           yi=mod(yi,boxysize)
21737           if (yi.lt.0) yi=yi+boxysize
21738           zi=mod(zi,boxzsize)
21739           if (zi.lt.0) zi=zi+boxzsize
21740
21741           do j=i+1,itmp+nres_molec(5)
21742 !           print *,i,j,'catcat'
21743            xj=c(1,j)
21744            yj=c(2,j)
21745            zj=c(3,j)
21746           xj=dmod(xj,boxxsize)
21747           if (xj.lt.0) xj=xj+boxxsize
21748           yj=dmod(yj,boxysize)
21749           if (yj.lt.0) yj=yj+boxysize
21750           zj=dmod(zj,boxzsize)
21751           if (zj.lt.0) zj=zj+boxzsize
21752 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
21753       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21754       xj_safe=xj
21755       yj_safe=yj
21756       zj_safe=zj
21757       subchap=0
21758       do xshift=-1,1
21759       do yshift=-1,1
21760       do zshift=-1,1
21761           xj=xj_safe+xshift*boxxsize
21762           yj=yj_safe+yshift*boxysize
21763           zj=zj_safe+zshift*boxzsize
21764           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21765           if(dist_temp.lt.dist_init) then
21766             dist_init=dist_temp
21767             xj_temp=xj
21768             yj_temp=yj
21769             zj_temp=zj
21770             subchap=1
21771           endif
21772        enddo
21773        enddo
21774        enddo
21775        if (subchap.eq.1) then
21776           xj=xj_temp-xi
21777           yj=yj_temp-yi
21778           zj=zj_temp-zi
21779        else
21780           xj=xj_safe-xi
21781           yj=yj_safe-yi
21782           zj=zj_safe-zi
21783        endif
21784        rcal =xj**2+yj**2+zj**2
21785         ract=sqrt(rcal)
21786 !        rcat0=3.472
21787 !        epscalc=0.05
21788 !        r06 = rcat0**6
21789 !        r012 = r06**2
21790 !        k0 = 332*(2*2)/80
21791         Evan1cat=epscalc*(r012/rcal**6)
21792         Evan2cat=epscalc*2*(r06/rcal**3)
21793         Eeleccat=k0/ract
21794         r7 = rcal**7
21795         r4 = rcal**4
21796         r(1)=xj
21797         r(2)=yj
21798         r(3)=zj
21799         do k=1,3
21800           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21801           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21802           dEeleccat(k)=-k0*r(k)/ract**3
21803         enddo
21804         do k=1,3
21805           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21806           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
21807           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
21808         enddo
21809
21810 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
21811         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
21812        enddo
21813        enddo
21814        return
21815        end subroutine ecatcat
21816 !---------------------------------------------------------------------------
21817        subroutine ecat_prot(ecation_prot)
21818        integer i,j,k,subchap,itmp,inum
21819         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21820         r7,r4,ecationcation
21821         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21822         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
21823         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
21824         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
21825         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
21826         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
21827         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
21828         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
21829         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
21830         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
21831         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
21832         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21833         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
21834         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
21835         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
21836         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
21837         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
21838         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
21839         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
21840         dEvan1Cat
21841         real(kind=8),dimension(6) :: vcatprm
21842         ecation_prot=0.0d0
21843 ! first lets calculate interaction with peptide groups
21844         if (nres_molec(5).eq.0) return
21845          wconst=78
21846         wdip =1.092777950857032D2
21847         wdip=wdip/wconst
21848         wmodquad=-2.174122713004870D4
21849         wmodquad=wmodquad/wconst
21850         wquad1 = 3.901232068562804D1
21851         wquad1=wquad1/wconst
21852         wquad2 = 3
21853         wquad2=wquad2/wconst
21854         wvan1 = 0.1
21855         wvan2 = 6
21856         itmp=0
21857         do i=1,4
21858         itmp=itmp+nres_molec(i)
21859         enddo
21860 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
21861         do i=ibond_start,ibond_end
21862 !         cycle
21863          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
21864         xi=0.5d0*(c(1,i)+c(1,i+1))
21865         yi=0.5d0*(c(2,i)+c(2,i+1))
21866         zi=0.5d0*(c(3,i)+c(3,i+1))
21867           xi=mod(xi,boxxsize)
21868           if (xi.lt.0) xi=xi+boxxsize
21869           yi=mod(yi,boxysize)
21870           if (yi.lt.0) yi=yi+boxysize
21871           zi=mod(zi,boxzsize)
21872           if (zi.lt.0) zi=zi+boxzsize
21873
21874          do j=itmp+1,itmp+nres_molec(5)
21875            xj=c(1,j)
21876            yj=c(2,j)
21877            zj=c(3,j)
21878           xj=dmod(xj,boxxsize)
21879           if (xj.lt.0) xj=xj+boxxsize
21880           yj=dmod(yj,boxysize)
21881           if (yj.lt.0) yj=yj+boxysize
21882           zj=dmod(zj,boxzsize)
21883           if (zj.lt.0) zj=zj+boxzsize
21884       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21885       xj_safe=xj
21886       yj_safe=yj
21887       zj_safe=zj
21888       subchap=0
21889       do xshift=-1,1
21890       do yshift=-1,1
21891       do zshift=-1,1
21892           xj=xj_safe+xshift*boxxsize
21893           yj=yj_safe+yshift*boxysize
21894           zj=zj_safe+zshift*boxzsize
21895           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21896           if(dist_temp.lt.dist_init) then
21897             dist_init=dist_temp
21898             xj_temp=xj
21899             yj_temp=yj
21900             zj_temp=zj
21901             subchap=1
21902           endif
21903        enddo
21904        enddo
21905        enddo
21906        if (subchap.eq.1) then
21907           xj=xj_temp-xi
21908           yj=yj_temp-yi
21909           zj=zj_temp-zi
21910        else
21911           xj=xj_safe-xi
21912           yj=yj_safe-yi
21913           zj=zj_safe-zi
21914        endif
21915 !       enddo
21916 !       enddo
21917        rcpm = sqrt(xj**2+yj**2+zj**2)
21918        drcp_norm(1)=xj/rcpm
21919        drcp_norm(2)=yj/rcpm
21920        drcp_norm(3)=zj/rcpm
21921        dcmag=0.0
21922        do k=1,3
21923        dcmag=dcmag+dc(k,i)**2
21924        enddo
21925        dcmag=dsqrt(dcmag)
21926        do k=1,3
21927          myd_norm(k)=dc(k,i)/dcmag
21928        enddo
21929         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
21930         drcp_norm(3)*myd_norm(3)
21931         rsecp = rcpm**2
21932         Ir = 1.0d0/rcpm
21933         Irsecp = 1.0d0/rsecp
21934         Irthrp = Irsecp/rcpm
21935         Irfourp = Irthrp/rcpm
21936         Irfiftp = Irfourp/rcpm
21937         Irsistp=Irfiftp/rcpm
21938         Irseven=Irsistp/rcpm
21939         Irtwelv=Irsistp*Irsistp
21940         Irthir=Irtwelv/rcpm
21941         sin2thet = (1-costhet*costhet)
21942         sinthet=sqrt(sin2thet)
21943         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
21944              *sin2thet
21945         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
21946              2*wvan2**6*Irsistp)
21947         ecation_prot = ecation_prot+E1+E2
21948         dE1dr = -2*costhet*wdip*Irthrp-&
21949          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
21950         dE2dr = 3*wquad1*wquad2*Irfourp-     &
21951           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
21952         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
21953         do k=1,3
21954           drdpep(k) = -drcp_norm(k)
21955           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
21956           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
21957           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
21958           dEddci(k) = dEdcos*dcosddci(k)
21959         enddo
21960         do k=1,3
21961         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
21962         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
21963         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
21964         enddo
21965        enddo ! j
21966        enddo ! i
21967 !------------------------------------------sidechains
21968 !        do i=1,nres_molec(1)
21969         do i=ibond_start,ibond_end
21970          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
21971 !         cycle
21972 !        print *,i,ecation_prot
21973         xi=(c(1,i+nres))
21974         yi=(c(2,i+nres))
21975         zi=(c(3,i+nres))
21976           xi=mod(xi,boxxsize)
21977           if (xi.lt.0) xi=xi+boxxsize
21978           yi=mod(yi,boxysize)
21979           if (yi.lt.0) yi=yi+boxysize
21980           zi=mod(zi,boxzsize)
21981           if (zi.lt.0) zi=zi+boxzsize
21982           do k=1,3
21983             cm1(k)=dc(k,i+nres)
21984           enddo
21985            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
21986          do j=itmp+1,itmp+nres_molec(5)
21987            xj=c(1,j)
21988            yj=c(2,j)
21989            zj=c(3,j)
21990           xj=dmod(xj,boxxsize)
21991           if (xj.lt.0) xj=xj+boxxsize
21992           yj=dmod(yj,boxysize)
21993           if (yj.lt.0) yj=yj+boxysize
21994           zj=dmod(zj,boxzsize)
21995           if (zj.lt.0) zj=zj+boxzsize
21996       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21997       xj_safe=xj
21998       yj_safe=yj
21999       zj_safe=zj
22000       subchap=0
22001       do xshift=-1,1
22002       do yshift=-1,1
22003       do zshift=-1,1
22004           xj=xj_safe+xshift*boxxsize
22005           yj=yj_safe+yshift*boxysize
22006           zj=zj_safe+zshift*boxzsize
22007           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22008           if(dist_temp.lt.dist_init) then
22009             dist_init=dist_temp
22010             xj_temp=xj
22011             yj_temp=yj
22012             zj_temp=zj
22013             subchap=1
22014           endif
22015        enddo
22016        enddo
22017        enddo
22018        if (subchap.eq.1) then
22019           xj=xj_temp-xi
22020           yj=yj_temp-yi
22021           zj=zj_temp-zi
22022        else
22023           xj=xj_safe-xi
22024           yj=yj_safe-yi
22025           zj=zj_safe-zi
22026        endif
22027 !       enddo
22028 !       enddo
22029          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22030             if(itype(i,1).eq.16) then
22031             inum=1
22032             else
22033             inum=2
22034             endif
22035             do k=1,6
22036             vcatprm(k)=catprm(k,inum)
22037             enddo
22038             dASGL=catprm(7,inum)
22039              do k=1,3
22040                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22041                 valpha(k)=c(k,i)
22042                 vcat(k)=c(k,j)
22043               enddo
22044                       do k=1,3
22045           dx(k) = vcat(k)-vcm(k)
22046         enddo
22047         do k=1,3
22048           v1(k)=(vcm(k)-valpha(k))
22049           v2(k)=(vcat(k)-valpha(k))
22050         enddo
22051         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22052         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22053         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22054
22055 !  The weights of the energy function calculated from
22056 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22057         wh2o=78
22058         wc = vcatprm(1)
22059         wc=wc/wh2o
22060         wdip =vcatprm(2)
22061         wdip=wdip/wh2o
22062         wquad1 =vcatprm(3)
22063         wquad1=wquad1/wh2o
22064         wquad2 = vcatprm(4)
22065         wquad2=wquad2/wh2o
22066         wquad2p = 1-wquad2
22067         wvan1 = vcatprm(5)
22068         wvan2 =vcatprm(6)
22069         opt = dx(1)**2+dx(2)**2
22070         rsecp = opt+dx(3)**2
22071         rs = sqrt(rsecp)
22072         rthrp = rsecp*rs
22073         rfourp = rthrp*rs
22074         rsixp = rfourp*rsecp
22075         reight=rsixp*rsecp
22076         Ir = 1.0d0/rs
22077         Irsecp = 1/rsecp
22078         Irthrp = Irsecp/rs
22079         Irfourp = Irthrp/rs
22080         Irsixp = 1/rsixp
22081         Ireight=1/reight
22082         Irtw=Irsixp*Irsixp
22083         Irthir=Irtw/rs
22084         Irfourt=Irthir/rs
22085         opt1 = (4*rs*dx(3)*wdip)
22086         opt2 = 6*rsecp*wquad1*opt
22087         opt3 = wquad1*wquad2p*Irsixp
22088         opt4 = (wvan1*wvan2**12)
22089         opt5 = opt4*12*Irfourt
22090         opt6 = 2*wvan1*wvan2**6
22091         opt7 = 6*opt6*Ireight
22092         opt8 = wdip/v1m
22093         opt10 = wdip/v2m
22094         opt11 = (rsecp*v2m)**2
22095         opt12 = (rsecp*v1m)**2
22096         opt14 = (v1m*v2m*rsecp)**2
22097         opt15 = -wquad1/v2m**2
22098         opt16 = (rthrp*(v1m*v2m)**2)**2
22099         opt17 = (v1m**2*rthrp)**2
22100         opt18 = -wquad1/rthrp
22101         opt19 = (v1m**2*v2m**2)**2
22102         Ec = wc*Ir
22103         do k=1,3
22104           dEcCat(k) = -(dx(k)*wc)*Irthrp
22105           dEcCm(k)=(dx(k)*wc)*Irthrp
22106           dEcCalp(k)=0.0d0
22107         enddo
22108         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22109         do k=1,3
22110           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22111                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22112           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22113                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22114           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22115                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22116                       *v1dpv2)/opt14
22117         enddo
22118         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22119         do k=1,3
22120           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22121                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22122                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22123           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22124                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22125                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22126           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22127                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22128                         v1dpv2**2)/opt19
22129         enddo
22130         Equad2=wquad1*wquad2p*Irthrp
22131         do k=1,3
22132           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22133           dEquad2Cm(k)=3*dx(k)*rs*opt3
22134           dEquad2Calp(k)=0.0d0
22135         enddo
22136         Evan1=opt4*Irtw
22137         do k=1,3
22138           dEvan1Cat(k)=-dx(k)*opt5
22139           dEvan1Cm(k)=dx(k)*opt5
22140           dEvan1Calp(k)=0.0d0
22141         enddo
22142         Evan2=-opt6*Irsixp
22143         do k=1,3
22144           dEvan2Cat(k)=dx(k)*opt7
22145           dEvan2Cm(k)=-dx(k)*opt7
22146           dEvan2Calp(k)=0.0d0
22147         enddo
22148         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22149 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22150
22151         do k=1,3
22152           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22153                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22154 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22155           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22156                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22157           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22158                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22159         enddo
22160             dscmag = 0.0d0
22161             do k=1,3
22162               dscvec(k) = dc(k,i+nres)
22163               dscmag = dscmag+dscvec(k)*dscvec(k)
22164             enddo
22165             dscmag3 = dscmag
22166             dscmag = sqrt(dscmag)
22167             dscmag3 = dscmag3*dscmag
22168             constA = 1.0d0+dASGL/dscmag
22169             constB = 0.0d0
22170             do k=1,3
22171               constB = constB+dscvec(k)*dEtotalCm(k)
22172             enddo
22173             constB = constB*dASGL/dscmag3
22174             do k=1,3
22175               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22176               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22177                constA*dEtotalCm(k)-constB*dscvec(k)
22178 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22179               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22180               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22181              enddo
22182         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22183            if(itype(i,1).eq.14) then
22184             inum=3
22185             else
22186             inum=4
22187             endif
22188             do k=1,6
22189             vcatprm(k)=catprm(k,inum)
22190             enddo
22191             dASGL=catprm(7,inum)
22192              do k=1,3
22193                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22194                 valpha(k)=c(k,i)
22195                 vcat(k)=c(k,j)
22196               enddo
22197
22198         do k=1,3
22199           dx(k) = vcat(k)-vcm(k)
22200         enddo
22201         do k=1,3
22202           v1(k)=(vcm(k)-valpha(k))
22203           v2(k)=(vcat(k)-valpha(k))
22204         enddo
22205         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22206         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22207         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22208 !  The weights of the energy function calculated from
22209 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22210         wh2o=78
22211         wdip =vcatprm(2)
22212         wdip=wdip/wh2o
22213         wquad1 =vcatprm(3)
22214         wquad1=wquad1/wh2o
22215         wquad2 = vcatprm(4)
22216         wquad2=wquad2/wh2o
22217         wquad2p = 1-wquad2
22218         wvan1 = vcatprm(5)
22219         wvan2 =vcatprm(6)
22220         opt = dx(1)**2+dx(2)**2
22221         rsecp = opt+dx(3)**2
22222         rs = sqrt(rsecp)
22223         rthrp = rsecp*rs
22224         rfourp = rthrp*rs
22225         rsixp = rfourp*rsecp
22226         reight=rsixp*rsecp
22227         Ir = 1.0d0/rs
22228         Irsecp = 1/rsecp
22229         Irthrp = Irsecp/rs
22230         Irfourp = Irthrp/rs
22231         Irsixp = 1/rsixp
22232         Ireight=1/reight
22233         Irtw=Irsixp*Irsixp
22234         Irthir=Irtw/rs
22235         Irfourt=Irthir/rs
22236         opt1 = (4*rs*dx(3)*wdip)
22237         opt2 = 6*rsecp*wquad1*opt
22238         opt3 = wquad1*wquad2p*Irsixp
22239         opt4 = (wvan1*wvan2**12)
22240         opt5 = opt4*12*Irfourt
22241         opt6 = 2*wvan1*wvan2**6
22242         opt7 = 6*opt6*Ireight
22243         opt8 = wdip/v1m
22244         opt10 = wdip/v2m
22245         opt11 = (rsecp*v2m)**2
22246         opt12 = (rsecp*v1m)**2
22247         opt14 = (v1m*v2m*rsecp)**2
22248         opt15 = -wquad1/v2m**2
22249         opt16 = (rthrp*(v1m*v2m)**2)**2
22250         opt17 = (v1m**2*rthrp)**2
22251         opt18 = -wquad1/rthrp
22252         opt19 = (v1m**2*v2m**2)**2
22253         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22254         do k=1,3
22255           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22256                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22257          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22258                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22259           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22260                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22261                       *v1dpv2)/opt14
22262         enddo
22263         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22264         do k=1,3
22265           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22266                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22267                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22268           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22269                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22270                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22271           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22272                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22273                         v1dpv2**2)/opt19
22274         enddo
22275         Equad2=wquad1*wquad2p*Irthrp
22276         do k=1,3
22277           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22278           dEquad2Cm(k)=3*dx(k)*rs*opt3
22279           dEquad2Calp(k)=0.0d0
22280         enddo
22281         Evan1=opt4*Irtw
22282         do k=1,3
22283           dEvan1Cat(k)=-dx(k)*opt5
22284           dEvan1Cm(k)=dx(k)*opt5
22285           dEvan1Calp(k)=0.0d0
22286         enddo
22287         Evan2=-opt6*Irsixp
22288         do k=1,3
22289           dEvan2Cat(k)=dx(k)*opt7
22290           dEvan2Cm(k)=-dx(k)*opt7
22291           dEvan2Calp(k)=0.0d0
22292         enddo
22293          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22294         do k=1,3
22295           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22296                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22297           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22298                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22299           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22300                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22301         enddo
22302             dscmag = 0.0d0
22303             do k=1,3
22304               dscvec(k) = c(k,i+nres)-c(k,i)
22305               dscmag = dscmag+dscvec(k)*dscvec(k)
22306             enddo
22307             dscmag3 = dscmag
22308             dscmag = sqrt(dscmag)
22309             dscmag3 = dscmag3*dscmag
22310             constA = 1+dASGL/dscmag
22311             constB = 0.0d0
22312             do k=1,3
22313               constB = constB+dscvec(k)*dEtotalCm(k)
22314             enddo
22315             constB = constB*dASGL/dscmag3
22316             do k=1,3
22317               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22318               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22319                constA*dEtotalCm(k)-constB*dscvec(k)
22320               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22321               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22322              enddo
22323            else
22324             rcal = 0.0d0
22325             do k=1,3
22326               r(k) = c(k,j)-c(k,i+nres)
22327               rcal = rcal+r(k)*r(k)
22328             enddo
22329             ract=sqrt(rcal)
22330             rocal=1.5
22331             epscalc=0.2
22332             r0p=0.5*(rocal+sig0(itype(i,1)))
22333             r06 = r0p**6
22334             r012 = r06*r06
22335             Evan1=epscalc*(r012/rcal**6)
22336             Evan2=epscalc*2*(r06/rcal**3)
22337             r4 = rcal**4
22338             r7 = rcal**7
22339             do k=1,3
22340               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22341               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22342             enddo
22343             do k=1,3
22344               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22345             enddo
22346                  ecation_prot = ecation_prot+ Evan1+Evan2
22347             do  k=1,3
22348                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22349                dEtotalCm(k)
22350               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22351               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22352              enddo
22353          endif ! 13-16 residues
22354        enddo !j
22355        enddo !i
22356        return
22357        end subroutine ecat_prot
22358
22359 !----------------------------------------------------------------------------
22360 !-----------------------------------------------------------------------------
22361 !-----------------------------------------------------------------------------
22362       subroutine eprot_sc_base(escbase)
22363       use calc_data
22364 !      implicit real*8 (a-h,o-z)
22365 !      include 'DIMENSIONS'
22366 !      include 'COMMON.GEO'
22367 !      include 'COMMON.VAR'
22368 !      include 'COMMON.LOCAL'
22369 !      include 'COMMON.CHAIN'
22370 !      include 'COMMON.DERIV'
22371 !      include 'COMMON.NAMES'
22372 !      include 'COMMON.INTERACT'
22373 !      include 'COMMON.IOUNITS'
22374 !      include 'COMMON.CALC'
22375 !      include 'COMMON.CONTROL'
22376 !      include 'COMMON.SBRIDGE'
22377       logical :: lprn
22378 !el local variables
22379       integer :: iint,itypi,itypi1,itypj,subchap
22380       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22381       real(kind=8) :: evdw,sig0ij
22382       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22383                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22384                     sslipi,sslipj,faclip
22385       integer :: ii
22386       real(kind=8) :: fracinbuf
22387        real (kind=8) :: escbase
22388        real (kind=8),dimension(4):: ener
22389        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22390        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22391         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22392         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22393         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22394         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22395         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22396         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22397        real(kind=8),dimension(3,2)::chead,erhead_tail
22398        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22399        integer troll
22400        eps_out=80.0d0
22401        escbase=0.0d0
22402 !       do i=1,nres_molec(1)
22403         do i=ibond_start,ibond_end
22404         if (itype(i,1).eq.ntyp1_molec(1)) cycle
22405         itypi  = itype(i,1)
22406         dxi    = dc_norm(1,nres+i)
22407         dyi    = dc_norm(2,nres+i)
22408         dzi    = dc_norm(3,nres+i)
22409         dsci_inv = vbld_inv(i+nres)
22410         xi=c(1,nres+i)
22411         yi=c(2,nres+i)
22412         zi=c(3,nres+i)
22413         xi=mod(xi,boxxsize)
22414          if (xi.lt.0) xi=xi+boxxsize
22415         yi=mod(yi,boxysize)
22416          if (yi.lt.0) yi=yi+boxysize
22417         zi=mod(zi,boxzsize)
22418          if (zi.lt.0) zi=zi+boxzsize
22419          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22420            itypj= itype(j,2)
22421            if (itype(j,2).eq.ntyp1_molec(2))cycle
22422            xj=c(1,j+nres)
22423            yj=c(2,j+nres)
22424            zj=c(3,j+nres)
22425            xj=dmod(xj,boxxsize)
22426            if (xj.lt.0) xj=xj+boxxsize
22427            yj=dmod(yj,boxysize)
22428            if (yj.lt.0) yj=yj+boxysize
22429            zj=dmod(zj,boxzsize)
22430            if (zj.lt.0) zj=zj+boxzsize
22431           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22432           xj_safe=xj
22433           yj_safe=yj
22434           zj_safe=zj
22435           subchap=0
22436
22437           do xshift=-1,1
22438           do yshift=-1,1
22439           do zshift=-1,1
22440           xj=xj_safe+xshift*boxxsize
22441           yj=yj_safe+yshift*boxysize
22442           zj=zj_safe+zshift*boxzsize
22443           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22444           if(dist_temp.lt.dist_init) then
22445             dist_init=dist_temp
22446             xj_temp=xj
22447             yj_temp=yj
22448             zj_temp=zj
22449             subchap=1
22450           endif
22451           enddo
22452           enddo
22453           enddo
22454           if (subchap.eq.1) then
22455           xj=xj_temp-xi
22456           yj=yj_temp-yi
22457           zj=zj_temp-zi
22458           else
22459           xj=xj_safe-xi
22460           yj=yj_safe-yi
22461           zj=zj_safe-zi
22462           endif
22463           dxj = dc_norm( 1, nres+j )
22464           dyj = dc_norm( 2, nres+j )
22465           dzj = dc_norm( 3, nres+j )
22466 !          print *,i,j,itypi,itypj
22467           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
22468           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
22469 !          d1i=0.0d0
22470 !          d1j=0.0d0
22471 !          BetaT = 1.0d0 / (298.0d0 * Rb)
22472 ! Gay-berne var's
22473           sig0ij = sigma_scbase( itypi,itypj )
22474           chi1   = chi_scbase( itypi, itypj,1 )
22475           chi2   = chi_scbase( itypi, itypj,2 )
22476 !          chi1=0.0d0
22477 !          chi2=0.0d0
22478           chi12  = chi1 * chi2
22479           chip1  = chipp_scbase( itypi, itypj,1 )
22480           chip2  = chipp_scbase( itypi, itypj,2 )
22481 !          chip1=0.0d0
22482 !          chip2=0.0d0
22483           chip12 = chip1 * chip2
22484 ! not used by momo potential, but needed by sc_angular which is shared
22485 ! by all energy_potential subroutines
22486           alf1   = 0.0d0
22487           alf2   = 0.0d0
22488           alf12  = 0.0d0
22489           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
22490 !       a12sq = a12sq * a12sq
22491 ! charge of amino acid itypi is...
22492           chis1 = chis_scbase(itypi,itypj,1)
22493           chis2 = chis_scbase(itypi,itypj,2)
22494           chis12 = chis1 * chis2
22495           sig1 = sigmap1_scbase(itypi,itypj)
22496           sig2 = sigmap2_scbase(itypi,itypj)
22497 !       write (*,*) "sig1 = ", sig1
22498 !       write (*,*) "sig2 = ", sig2
22499 ! alpha factors from Fcav/Gcav
22500           b1 = alphasur_scbase(1,itypi,itypj)
22501 !          b1=0.0d0
22502           b2 = alphasur_scbase(2,itypi,itypj)
22503           b3 = alphasur_scbase(3,itypi,itypj)
22504           b4 = alphasur_scbase(4,itypi,itypj)
22505 ! used to determine whether we want to do quadrupole calculations
22506 ! used by Fgb
22507        eps_in = epsintab_scbase(itypi,itypj)
22508        if (eps_in.eq.0.0) eps_in=1.0
22509        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22510 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
22511 !-------------------------------------------------------------------
22512 ! tail location and distance calculations
22513        DO k = 1,3
22514 ! location of polar head is computed by taking hydrophobic centre
22515 ! and moving by a d1 * dc_norm vector
22516 ! see unres publications for very informative images
22517         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
22518         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
22519 ! distance
22520 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22521 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22522         Rhead_distance(k) = chead(k,2) - chead(k,1)
22523        END DO
22524 ! pitagoras (root of sum of squares)
22525        Rhead = dsqrt( &
22526           (Rhead_distance(1)*Rhead_distance(1)) &
22527         + (Rhead_distance(2)*Rhead_distance(2)) &
22528         + (Rhead_distance(3)*Rhead_distance(3)))
22529 !-------------------------------------------------------------------
22530 ! zero everything that should be zero'ed
22531        evdwij = 0.0d0
22532        ECL = 0.0d0
22533        Elj = 0.0d0
22534        Equad = 0.0d0
22535        Epol = 0.0d0
22536        Fcav=0.0d0
22537        eheadtail = 0.0d0
22538        dGCLdOM1 = 0.0d0
22539        dGCLdOM2 = 0.0d0
22540        dGCLdOM12 = 0.0d0
22541        dPOLdOM1 = 0.0d0
22542        dPOLdOM2 = 0.0d0
22543           Fcav = 0.0d0
22544           dFdR = 0.0d0
22545           dCAVdOM1  = 0.0d0
22546           dCAVdOM2  = 0.0d0
22547           dCAVdOM12 = 0.0d0
22548           dscj_inv = vbld_inv(j+nres)
22549 !          print *,i,j,dscj_inv,dsci_inv
22550 ! rij holds 1/(distance of Calpha atoms)
22551           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22552           rij  = dsqrt(rrij)
22553 !----------------------------
22554           CALL sc_angular
22555 ! this should be in elgrad_init but om's are calculated by sc_angular
22556 ! which in turn is used by older potentials
22557 ! om = omega, sqom = om^2
22558           sqom1  = om1 * om1
22559           sqom2  = om2 * om2
22560           sqom12 = om12 * om12
22561
22562 ! now we calculate EGB - Gey-Berne
22563 ! It will be summed up in evdwij and saved in evdw
22564           sigsq     = 1.0D0  / sigsq
22565           sig       = sig0ij * dsqrt(sigsq)
22566 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22567           rij_shift = 1.0/rij - sig + sig0ij
22568           IF (rij_shift.le.0.0D0) THEN
22569            evdw = 1.0D20
22570            RETURN
22571           END IF
22572           sigder = -sig * sigsq
22573           rij_shift = 1.0D0 / rij_shift
22574           fac       = rij_shift**expon
22575           c1        = fac  * fac * aa_scbase(itypi,itypj)
22576 !          c1        = 0.0d0
22577           c2        = fac  * bb_scbase(itypi,itypj)
22578 !          c2        = 0.0d0
22579           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22580           eps2der   = eps3rt * evdwij
22581           eps3der   = eps2rt * evdwij
22582 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22583           evdwij    = eps2rt * eps3rt * evdwij
22584           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22585           fac    = -expon * (c1 + evdwij) * rij_shift
22586           sigder = fac * sigder
22587 !          fac    = rij * fac
22588 ! Calculate distance derivative
22589           gg(1) =  fac
22590           gg(2) =  fac
22591           gg(3) =  fac
22592 !          if (b2.gt.0.0) then
22593           fac = chis1 * sqom1 + chis2 * sqom2 &
22594           - 2.0d0 * chis12 * om1 * om2 * om12
22595 ! we will use pom later in Gcav, so dont mess with it!
22596           pom = 1.0d0 - chis1 * chis2 * sqom12
22597           Lambf = (1.0d0 - (fac / pom))
22598           Lambf = dsqrt(Lambf)
22599           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22600 !       write (*,*) "sparrow = ", sparrow
22601           Chif = 1.0d0/rij * sparrow
22602           ChiLambf = Chif * Lambf
22603           eagle = dsqrt(ChiLambf)
22604           bat = ChiLambf ** 11.0d0
22605           top = b1 * ( eagle + b2 * ChiLambf - b3 )
22606           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
22607           botsq = bot * bot
22608           Fcav = top / bot
22609 !          print *,i,j,Fcav
22610           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
22611           dbot = 12.0d0 * b4 * bat * Lambf
22612           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22613 !       dFdR = 0.0d0
22614 !      write (*,*) "dFcav/dR = ", dFdR
22615           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
22616           dbot = 12.0d0 * b4 * bat * Chif
22617           eagle = Lambf * pom
22618           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22619           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22620           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22621               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22622
22623           dFdL = ((dtop * bot - top * dbot) / botsq)
22624 !       dFdL = 0.0d0
22625           dCAVdOM1  = dFdL * ( dFdOM1 )
22626           dCAVdOM2  = dFdL * ( dFdOM2 )
22627           dCAVdOM12 = dFdL * ( dFdOM12 )
22628
22629           ertail(1) = xj*rij
22630           ertail(2) = yj*rij
22631           ertail(3) = zj*rij
22632 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
22633 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
22634 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
22635 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
22636 !           print *,"EOMY",eom1,eom2,eom12
22637 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22638 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
22639 ! here dtail=0.0
22640 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
22641 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22642        DO k = 1, 3
22643 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22644 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22645         pom = ertail(k)
22646 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22647         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22648                   - (( dFdR + gg(k) ) * pom)
22649 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22650 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22651 !     &             - ( dFdR * pom )
22652         pom = ertail(k)
22653 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22654         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22655                   + (( dFdR + gg(k) ) * pom)
22656 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22657 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22658 !c!     &             + ( dFdR * pom )
22659
22660         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22661                   - (( dFdR + gg(k) ) * ertail(k))
22662 !c!     &             - ( dFdR * ertail(k))
22663
22664         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22665                   + (( dFdR + gg(k) ) * ertail(k))
22666 !c!     &             + ( dFdR * ertail(k))
22667
22668         gg(k) = 0.0d0
22669 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22670 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22671       END DO
22672
22673 !          else
22674
22675 !          endif
22676 !Now dipole-dipole
22677          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
22678        w1 = wdipdip_scbase(1,itypi,itypj)
22679        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
22680        w3 = wdipdip_scbase(2,itypi,itypj)
22681 !c!-------------------------------------------------------------------
22682 !c! ECL
22683        fac = (om12 - 3.0d0 * om1 * om2)
22684        c1 = (w1 / (Rhead**3.0d0)) * fac
22685        c2 = (w2 / Rhead ** 6.0d0)  &
22686          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22687        c3= (w3/ Rhead ** 6.0d0)  &
22688          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22689        ECL = c1 - c2 + c3
22690 !c!       write (*,*) "w1 = ", w1
22691 !c!       write (*,*) "w2 = ", w2
22692 !c!       write (*,*) "om1 = ", om1
22693 !c!       write (*,*) "om2 = ", om2
22694 !c!       write (*,*) "om12 = ", om12
22695 !c!       write (*,*) "fac = ", fac
22696 !c!       write (*,*) "c1 = ", c1
22697 !c!       write (*,*) "c2 = ", c2
22698 !c!       write (*,*) "Ecl = ", Ecl
22699 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
22700 !c!       write (*,*) "c2_2 = ",
22701 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22702 !c!-------------------------------------------------------------------
22703 !c! dervative of ECL is GCL...
22704 !c! dECL/dr
22705        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
22706        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
22707          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
22708        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
22709          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22710        dGCLdR = c1 - c2 + c3
22711 !c! dECL/dom1
22712        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
22713        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22714          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
22715        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
22716        dGCLdOM1 = c1 - c2 + c3
22717 !c! dECL/dom2
22718        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
22719        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22720          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
22721        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
22722        dGCLdOM2 = c1 - c2 + c3
22723 !c! dECL/dom12
22724        c1 = w1 / (Rhead ** 3.0d0)
22725        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
22726        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
22727        dGCLdOM12 = c1 - c2 + c3
22728        DO k= 1, 3
22729         erhead(k) = Rhead_distance(k)/Rhead
22730        END DO
22731        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22732        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22733        facd1 = d1i * vbld_inv(i+nres)
22734        facd2 = d1j * vbld_inv(j+nres)
22735        DO k = 1, 3
22736
22737         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22738         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22739                   - dGCLdR * pom
22740         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22741         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22742                   + dGCLdR * pom
22743
22744         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22745                   - dGCLdR * erhead(k)
22746         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22747                   + dGCLdR * erhead(k)
22748        END DO
22749        endif
22750 !now charge with dipole eg. ARG-dG
22751        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
22752       alphapol1 = alphapol_scbase(itypi,itypj)
22753        w1        = wqdip_scbase(1,itypi,itypj)
22754        w2        = wqdip_scbase(2,itypi,itypj)
22755 !       w1=0.0d0
22756 !       w2=0.0d0
22757 !       pis       = sig0head_scbase(itypi,itypj)
22758 !       eps_head   = epshead_scbase(itypi,itypj)
22759 !c!-------------------------------------------------------------------
22760 !c! R1 - distance between head of ith side chain and tail of jth sidechain
22761        R1 = 0.0d0
22762        DO k = 1, 3
22763 !c! Calculate head-to-tail distances tail is center of side-chain
22764         R1=R1+(c(k,j+nres)-chead(k,1))**2
22765        END DO
22766 !c! Pitagoras
22767        R1 = dsqrt(R1)
22768
22769 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
22770 !c!     &        +dhead(1,1,itypi,itypj))**2))
22771 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
22772 !c!     &        +dhead(2,1,itypi,itypj))**2))
22773
22774 !c!-------------------------------------------------------------------
22775 !c! ecl
22776        sparrow  = w1  *  om1
22777        hawk     = w2 *  (1.0d0 - sqom2)
22778        Ecl = sparrow / Rhead**2.0d0 &
22779            - hawk    / Rhead**4.0d0
22780 !c!-------------------------------------------------------------------
22781 !c! derivative of ecl is Gcl
22782 !c! dF/dr part
22783        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
22784                 + 4.0d0 * hawk    / Rhead**5.0d0
22785 !c! dF/dom1
22786        dGCLdOM1 = (w1) / (Rhead**2.0d0)
22787 !c! dF/dom2
22788        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
22789 !c--------------------------------------------------------------------
22790 !c Polarization energy
22791 !c Epol
22792        MomoFac1 = (1.0d0 - chi1 * sqom2)
22793        RR1  = R1 * R1 / MomoFac1
22794        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
22795        fgb1 = sqrt( RR1 + a12sq * ee1)
22796 !       eps_inout_fac=0.0d0
22797        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
22798 ! derivative of Epol is Gpol...
22799        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
22800                 / (fgb1 ** 5.0d0)
22801        dFGBdR1 = ( (R1 / MomoFac1) &
22802              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
22803              / ( 2.0d0 * fgb1 )
22804        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
22805                * (2.0d0 - 0.5d0 * ee1) ) &
22806                / (2.0d0 * fgb1)
22807        dPOLdR1 = dPOLdFGB1 * dFGBdR1
22808 !       dPOLdR1 = 0.0d0
22809        dPOLdOM1 = 0.0d0
22810        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
22811        DO k = 1, 3
22812         erhead(k) = Rhead_distance(k)/Rhead
22813         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
22814        END DO
22815
22816        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22817        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22818        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
22819 !       bat=0.0d0
22820        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
22821        facd1 = d1i * vbld_inv(i+nres)
22822        facd2 = d1j * vbld_inv(j+nres)
22823 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22824
22825        DO k = 1, 3
22826         hawk = (erhead_tail(k,1) + &
22827         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
22828 !        facd1=0.0d0
22829 !        facd2=0.0d0
22830         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22831         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
22832                    - dGCLdR * pom &
22833                    - dPOLdR1 *  (erhead_tail(k,1))
22834 !     &             - dGLJdR * pom
22835
22836         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22837         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
22838                    + dGCLdR * pom  &
22839                    + dPOLdR1 * (erhead_tail(k,1))
22840 !     &             + dGLJdR * pom
22841
22842
22843         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
22844                   - dGCLdR * erhead(k) &
22845                   - dPOLdR1 * erhead_tail(k,1)
22846 !     &             - dGLJdR * erhead(k)
22847
22848         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
22849                   + dGCLdR * erhead(k)  &
22850                   + dPOLdR1 * erhead_tail(k,1)
22851 !     &             + dGLJdR * erhead(k)
22852
22853        END DO
22854        endif
22855 !       print *,i,j,evdwij,epol,Fcav,ECL
22856        escbase=escbase+evdwij+epol+Fcav+ECL
22857        call sc_grad_scbase
22858          enddo
22859       enddo
22860
22861       return
22862       end subroutine eprot_sc_base
22863       SUBROUTINE sc_grad_scbase
22864       use calc_data
22865
22866        real (kind=8) :: dcosom1(3),dcosom2(3)
22867        eom1  =    &
22868               eps2der * eps2rt_om1   &
22869             - 2.0D0 * alf1 * eps3der &
22870             + sigder * sigsq_om1     &
22871             + dCAVdOM1               &
22872             + dGCLdOM1               &
22873             + dPOLdOM1
22874
22875        eom2  =  &
22876               eps2der * eps2rt_om2   &
22877             + 2.0D0 * alf2 * eps3der &
22878             + sigder * sigsq_om2     &
22879             + dCAVdOM2               &
22880             + dGCLdOM2               &
22881             + dPOLdOM2
22882
22883        eom12 =    &
22884               evdwij  * eps1_om12     &
22885             + eps2der * eps2rt_om12   &
22886             - 2.0D0 * alf12 * eps3der &
22887             + sigder *sigsq_om12      &
22888             + dCAVdOM12               &
22889             + dGCLdOM12
22890
22891 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
22892 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
22893 !               gg(1),gg(2),"rozne"
22894        DO k = 1, 3
22895         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
22896         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
22897         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
22898         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
22899                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22900                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22901         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
22902                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22903                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22904         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
22905         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
22906        END DO
22907        RETURN
22908       END SUBROUTINE sc_grad_scbase
22909
22910
22911       subroutine epep_sc_base(epepbase)
22912       use calc_data
22913       logical :: lprn
22914 !el local variables
22915       integer :: iint,itypi,itypi1,itypj,subchap
22916       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22917       real(kind=8) :: evdw,sig0ij
22918       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22919                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22920                     sslipi,sslipj,faclip
22921       integer :: ii
22922       real(kind=8) :: fracinbuf
22923        real (kind=8) :: epepbase
22924        real (kind=8),dimension(4):: ener
22925        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22926        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22927         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22928         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22929         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22930         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22931         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22932         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22933        real(kind=8),dimension(3,2)::chead,erhead_tail
22934        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22935        integer troll
22936        eps_out=80.0d0
22937        epepbase=0.0d0
22938 !       do i=1,nres_molec(1)-1
22939         do i=ibond_start,ibond_end
22940         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
22941 !C        itypi  = itype(i,1)
22942         dxi    = dc_norm(1,i)
22943         dyi    = dc_norm(2,i)
22944         dzi    = dc_norm(3,i)
22945 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
22946         dsci_inv = vbld_inv(i+1)/2.0
22947         xi=(c(1,i)+c(1,i+1))/2.0
22948         yi=(c(2,i)+c(2,i+1))/2.0
22949         zi=(c(3,i)+c(3,i+1))/2.0
22950         xi=mod(xi,boxxsize)
22951          if (xi.lt.0) xi=xi+boxxsize
22952         yi=mod(yi,boxysize)
22953          if (yi.lt.0) yi=yi+boxysize
22954         zi=mod(zi,boxzsize)
22955          if (zi.lt.0) zi=zi+boxzsize
22956          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22957            itypj= itype(j,2)
22958            if (itype(j,2).eq.ntyp1_molec(2))cycle
22959            xj=c(1,j+nres)
22960            yj=c(2,j+nres)
22961            zj=c(3,j+nres)
22962            xj=dmod(xj,boxxsize)
22963            if (xj.lt.0) xj=xj+boxxsize
22964            yj=dmod(yj,boxysize)
22965            if (yj.lt.0) yj=yj+boxysize
22966            zj=dmod(zj,boxzsize)
22967            if (zj.lt.0) zj=zj+boxzsize
22968           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22969           xj_safe=xj
22970           yj_safe=yj
22971           zj_safe=zj
22972           subchap=0
22973
22974           do xshift=-1,1
22975           do yshift=-1,1
22976           do zshift=-1,1
22977           xj=xj_safe+xshift*boxxsize
22978           yj=yj_safe+yshift*boxysize
22979           zj=zj_safe+zshift*boxzsize
22980           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22981           if(dist_temp.lt.dist_init) then
22982             dist_init=dist_temp
22983             xj_temp=xj
22984             yj_temp=yj
22985             zj_temp=zj
22986             subchap=1
22987           endif
22988           enddo
22989           enddo
22990           enddo
22991           if (subchap.eq.1) then
22992           xj=xj_temp-xi
22993           yj=yj_temp-yi
22994           zj=zj_temp-zi
22995           else
22996           xj=xj_safe-xi
22997           yj=yj_safe-yi
22998           zj=zj_safe-zi
22999           endif
23000           dxj = dc_norm( 1, nres+j )
23001           dyj = dc_norm( 2, nres+j )
23002           dzj = dc_norm( 3, nres+j )
23003 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23004 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23005
23006 ! Gay-berne var's
23007           sig0ij = sigma_pepbase(itypj )
23008           chi1   = chi_pepbase(itypj,1 )
23009           chi2   = chi_pepbase(itypj,2 )
23010 !          chi1=0.0d0
23011 !          chi2=0.0d0
23012           chi12  = chi1 * chi2
23013           chip1  = chipp_pepbase(itypj,1 )
23014           chip2  = chipp_pepbase(itypj,2 )
23015 !          chip1=0.0d0
23016 !          chip2=0.0d0
23017           chip12 = chip1 * chip2
23018           chis1 = chis_pepbase(itypj,1)
23019           chis2 = chis_pepbase(itypj,2)
23020           chis12 = chis1 * chis2
23021           sig1 = sigmap1_pepbase(itypj)
23022           sig2 = sigmap2_pepbase(itypj)
23023 !       write (*,*) "sig1 = ", sig1
23024 !       write (*,*) "sig2 = ", sig2
23025        DO k = 1,3
23026 ! location of polar head is computed by taking hydrophobic centre
23027 ! and moving by a d1 * dc_norm vector
23028 ! see unres publications for very informative images
23029         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23030 ! + d1i * dc_norm(k, i+nres)
23031         chead(k,2) = c(k, j+nres)
23032 ! + d1j * dc_norm(k, j+nres)
23033 ! distance
23034 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23035 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23036         Rhead_distance(k) = chead(k,2) - chead(k,1)
23037 !        print *,gvdwc_pepbase(k,i)
23038
23039        END DO
23040        Rhead = dsqrt( &
23041           (Rhead_distance(1)*Rhead_distance(1)) &
23042         + (Rhead_distance(2)*Rhead_distance(2)) &
23043         + (Rhead_distance(3)*Rhead_distance(3)))
23044
23045 ! alpha factors from Fcav/Gcav
23046           b1 = alphasur_pepbase(1,itypj)
23047 !          b1=0.0d0
23048           b2 = alphasur_pepbase(2,itypj)
23049           b3 = alphasur_pepbase(3,itypj)
23050           b4 = alphasur_pepbase(4,itypj)
23051           alf1   = 0.0d0
23052           alf2   = 0.0d0
23053           alf12  = 0.0d0
23054           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23055 !          print *,i,j,rrij
23056           rij  = dsqrt(rrij)
23057 !----------------------------
23058        evdwij = 0.0d0
23059        ECL = 0.0d0
23060        Elj = 0.0d0
23061        Equad = 0.0d0
23062        Epol = 0.0d0
23063        Fcav=0.0d0
23064        eheadtail = 0.0d0
23065        dGCLdOM1 = 0.0d0
23066        dGCLdOM2 = 0.0d0
23067        dGCLdOM12 = 0.0d0
23068        dPOLdOM1 = 0.0d0
23069        dPOLdOM2 = 0.0d0
23070           Fcav = 0.0d0
23071           dFdR = 0.0d0
23072           dCAVdOM1  = 0.0d0
23073           dCAVdOM2  = 0.0d0
23074           dCAVdOM12 = 0.0d0
23075           dscj_inv = vbld_inv(j+nres)
23076           CALL sc_angular
23077 ! this should be in elgrad_init but om's are calculated by sc_angular
23078 ! which in turn is used by older potentials
23079 ! om = omega, sqom = om^2
23080           sqom1  = om1 * om1
23081           sqom2  = om2 * om2
23082           sqom12 = om12 * om12
23083
23084 ! now we calculate EGB - Gey-Berne
23085 ! It will be summed up in evdwij and saved in evdw
23086           sigsq     = 1.0D0  / sigsq
23087           sig       = sig0ij * dsqrt(sigsq)
23088           rij_shift = 1.0/rij - sig + sig0ij
23089           IF (rij_shift.le.0.0D0) THEN
23090            evdw = 1.0D20
23091            RETURN
23092           END IF
23093           sigder = -sig * sigsq
23094           rij_shift = 1.0D0 / rij_shift
23095           fac       = rij_shift**expon
23096           c1        = fac  * fac * aa_pepbase(itypj)
23097 !          c1        = 0.0d0
23098           c2        = fac  * bb_pepbase(itypj)
23099 !          c2        = 0.0d0
23100           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23101           eps2der   = eps3rt * evdwij
23102           eps3der   = eps2rt * evdwij
23103 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23104           evdwij    = eps2rt * eps3rt * evdwij
23105           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23106           fac    = -expon * (c1 + evdwij) * rij_shift
23107           sigder = fac * sigder
23108 !          fac    = rij * fac
23109 ! Calculate distance derivative
23110           gg(1) =  fac
23111           gg(2) =  fac
23112           gg(3) =  fac
23113           fac = chis1 * sqom1 + chis2 * sqom2 &
23114           - 2.0d0 * chis12 * om1 * om2 * om12
23115 ! we will use pom later in Gcav, so dont mess with it!
23116           pom = 1.0d0 - chis1 * chis2 * sqom12
23117           Lambf = (1.0d0 - (fac / pom))
23118           Lambf = dsqrt(Lambf)
23119           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23120 !       write (*,*) "sparrow = ", sparrow
23121           Chif = 1.0d0/rij * sparrow
23122           ChiLambf = Chif * Lambf
23123           eagle = dsqrt(ChiLambf)
23124           bat = ChiLambf ** 11.0d0
23125           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23126           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23127           botsq = bot * bot
23128           Fcav = top / bot
23129 !          print *,i,j,Fcav
23130           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23131           dbot = 12.0d0 * b4 * bat * Lambf
23132           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23133 !       dFdR = 0.0d0
23134 !      write (*,*) "dFcav/dR = ", dFdR
23135           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23136           dbot = 12.0d0 * b4 * bat * Chif
23137           eagle = Lambf * pom
23138           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23139           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23140           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23141               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23142
23143           dFdL = ((dtop * bot - top * dbot) / botsq)
23144 !       dFdL = 0.0d0
23145           dCAVdOM1  = dFdL * ( dFdOM1 )
23146           dCAVdOM2  = dFdL * ( dFdOM2 )
23147           dCAVdOM12 = dFdL * ( dFdOM12 )
23148
23149           ertail(1) = xj*rij
23150           ertail(2) = yj*rij
23151           ertail(3) = zj*rij
23152        DO k = 1, 3
23153 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23154 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23155         pom = ertail(k)
23156 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23157         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23158                   - (( dFdR + gg(k) ) * pom)/2.0
23159 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
23160 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23161 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23162 !     &             - ( dFdR * pom )
23163         pom = ertail(k)
23164 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23165         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23166                   + (( dFdR + gg(k) ) * pom)
23167 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23168 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23169 !c!     &             + ( dFdR * pom )
23170
23171         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23172                   - (( dFdR + gg(k) ) * ertail(k))/2.0
23173 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
23174
23175 !c!     &             - ( dFdR * ertail(k))
23176
23177         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23178                   + (( dFdR + gg(k) ) * ertail(k))
23179 !c!     &             + ( dFdR * ertail(k))
23180
23181         gg(k) = 0.0d0
23182 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23183 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23184       END DO
23185
23186
23187        w1 = wdipdip_pepbase(1,itypj)
23188        w2 = -wdipdip_pepbase(3,itypj)/2.0
23189        w3 = wdipdip_pepbase(2,itypj)
23190 !       w1=0.0d0
23191 !       w2=0.0d0
23192 !c!-------------------------------------------------------------------
23193 !c! ECL
23194 !       w3=0.0d0
23195        fac = (om12 - 3.0d0 * om1 * om2)
23196        c1 = (w1 / (Rhead**3.0d0)) * fac
23197        c2 = (w2 / Rhead ** 6.0d0)  &
23198          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23199        c3= (w3/ Rhead ** 6.0d0)  &
23200          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23201
23202        ECL = c1 - c2 + c3
23203
23204        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23205        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23206          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23207        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23208          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23209
23210        dGCLdR = c1 - c2 + c3
23211 !c! dECL/dom1
23212        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23213        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23214          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23215        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23216        dGCLdOM1 = c1 - c2 + c3
23217 !c! dECL/dom2
23218        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23219        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23220          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23221        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23222
23223        dGCLdOM2 = c1 - c2 + c3
23224 !c! dECL/dom12
23225        c1 = w1 / (Rhead ** 3.0d0)
23226        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23227        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23228        dGCLdOM12 = c1 - c2 + c3
23229        DO k= 1, 3
23230         erhead(k) = Rhead_distance(k)/Rhead
23231        END DO
23232        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23233        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23234 !       facd1 = d1 * vbld_inv(i+nres)
23235 !       facd2 = d2 * vbld_inv(j+nres)
23236        DO k = 1, 3
23237
23238 !        pom = erhead(k)
23239 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23240 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
23241 !                  - dGCLdR * pom
23242         pom = erhead(k)
23243 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23244         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23245                   + dGCLdR * pom
23246
23247         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23248                   - dGCLdR * erhead(k)/2.0d0
23249 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23250         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23251                   - dGCLdR * erhead(k)/2.0d0
23252 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23253         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23254                   + dGCLdR * erhead(k)
23255        END DO
23256 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
23257        epepbase=epepbase+evdwij+Fcav+ECL
23258        call sc_grad_pepbase
23259        enddo
23260        enddo
23261       END SUBROUTINE epep_sc_base
23262       SUBROUTINE sc_grad_pepbase
23263       use calc_data
23264
23265        real (kind=8) :: dcosom1(3),dcosom2(3)
23266        eom1  =    &
23267               eps2der * eps2rt_om1   &
23268             - 2.0D0 * alf1 * eps3der &
23269             + sigder * sigsq_om1     &
23270             + dCAVdOM1               &
23271             + dGCLdOM1               &
23272             + dPOLdOM1
23273
23274        eom2  =  &
23275               eps2der * eps2rt_om2   &
23276             + 2.0D0 * alf2 * eps3der &
23277             + sigder * sigsq_om2     &
23278             + dCAVdOM2               &
23279             + dGCLdOM2               &
23280             + dPOLdOM2
23281
23282        eom12 =    &
23283               evdwij  * eps1_om12     &
23284             + eps2der * eps2rt_om12   &
23285             - 2.0D0 * alf12 * eps3der &
23286             + sigder *sigsq_om12      &
23287             + dCAVdOM12               &
23288             + dGCLdOM12
23289 !        om12=0.0
23290 !        eom12=0.0
23291 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23292 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
23293 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23294 !                 *dsci_inv*2.0
23295 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23296 !               gg(1),gg(2),"rozne"
23297        DO k = 1, 3
23298         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
23299         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23300         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23301         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
23302                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23303                  *dsci_inv*2.0 &
23304                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23305         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
23306                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
23307                  *dsci_inv*2.0 &
23308                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23309 !         print *,eom12,eom2,om12,om2
23310 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23311 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23312         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
23313                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23314                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23315         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
23316        END DO
23317        RETURN
23318       END SUBROUTINE sc_grad_pepbase
23319       subroutine eprot_sc_phosphate(escpho)
23320       use calc_data
23321 !      implicit real*8 (a-h,o-z)
23322 !      include 'DIMENSIONS'
23323 !      include 'COMMON.GEO'
23324 !      include 'COMMON.VAR'
23325 !      include 'COMMON.LOCAL'
23326 !      include 'COMMON.CHAIN'
23327 !      include 'COMMON.DERIV'
23328 !      include 'COMMON.NAMES'
23329 !      include 'COMMON.INTERACT'
23330 !      include 'COMMON.IOUNITS'
23331 !      include 'COMMON.CALC'
23332 !      include 'COMMON.CONTROL'
23333 !      include 'COMMON.SBRIDGE'
23334       logical :: lprn
23335 !el local variables
23336       integer :: iint,itypi,itypi1,itypj,subchap
23337       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23338       real(kind=8) :: evdw,sig0ij
23339       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23340                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23341                     sslipi,sslipj,faclip,alpha_sco
23342       integer :: ii
23343       real(kind=8) :: fracinbuf
23344        real (kind=8) :: escpho
23345        real (kind=8),dimension(4):: ener
23346        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23347        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23348         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23349         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23350         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23351         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23352         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23353         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23354        real(kind=8),dimension(3,2)::chead,erhead_tail
23355        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23356        integer troll
23357        eps_out=80.0d0
23358        escpho=0.0d0
23359 !       do i=1,nres_molec(1)
23360         do i=ibond_start,ibond_end
23361         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23362         itypi  = itype(i,1)
23363         dxi    = dc_norm(1,nres+i)
23364         dyi    = dc_norm(2,nres+i)
23365         dzi    = dc_norm(3,nres+i)
23366         dsci_inv = vbld_inv(i+nres)
23367         xi=c(1,nres+i)
23368         yi=c(2,nres+i)
23369         zi=c(3,nres+i)
23370         xi=mod(xi,boxxsize)
23371          if (xi.lt.0) xi=xi+boxxsize
23372         yi=mod(yi,boxysize)
23373          if (yi.lt.0) yi=yi+boxysize
23374         zi=mod(zi,boxzsize)
23375          if (zi.lt.0) zi=zi+boxzsize
23376          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23377            itypj= itype(j,2)
23378            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23379             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23380            xj=(c(1,j)+c(1,j+1))/2.0
23381            yj=(c(2,j)+c(2,j+1))/2.0
23382            zj=(c(3,j)+c(3,j+1))/2.0
23383            xj=dmod(xj,boxxsize)
23384            if (xj.lt.0) xj=xj+boxxsize
23385            yj=dmod(yj,boxysize)
23386            if (yj.lt.0) yj=yj+boxysize
23387            zj=dmod(zj,boxzsize)
23388            if (zj.lt.0) zj=zj+boxzsize
23389           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23390           xj_safe=xj
23391           yj_safe=yj
23392           zj_safe=zj
23393           subchap=0
23394           do xshift=-1,1
23395           do yshift=-1,1
23396           do zshift=-1,1
23397           xj=xj_safe+xshift*boxxsize
23398           yj=yj_safe+yshift*boxysize
23399           zj=zj_safe+zshift*boxzsize
23400           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23401           if(dist_temp.lt.dist_init) then
23402             dist_init=dist_temp
23403             xj_temp=xj
23404             yj_temp=yj
23405             zj_temp=zj
23406             subchap=1
23407           endif
23408           enddo
23409           enddo
23410           enddo
23411           if (subchap.eq.1) then
23412           xj=xj_temp-xi
23413           yj=yj_temp-yi
23414           zj=zj_temp-zi
23415           else
23416           xj=xj_safe-xi
23417           yj=yj_safe-yi
23418           zj=zj_safe-zi
23419           endif
23420           dxj = dc_norm( 1,j )
23421           dyj = dc_norm( 2,j )
23422           dzj = dc_norm( 3,j )
23423           dscj_inv = vbld_inv(j+1)
23424
23425 ! Gay-berne var's
23426           sig0ij = sigma_scpho(itypi )
23427           chi1   = chi_scpho(itypi,1 )
23428           chi2   = chi_scpho(itypi,2 )
23429 !          chi1=0.0d0
23430 !          chi2=0.0d0
23431           chi12  = chi1 * chi2
23432           chip1  = chipp_scpho(itypi,1 )
23433           chip2  = chipp_scpho(itypi,2 )
23434 !          chip1=0.0d0
23435 !          chip2=0.0d0
23436           chip12 = chip1 * chip2
23437           chis1 = chis_scpho(itypi,1)
23438           chis2 = chis_scpho(itypi,2)
23439           chis12 = chis1 * chis2
23440           sig1 = sigmap1_scpho(itypi)
23441           sig2 = sigmap2_scpho(itypi)
23442 !       write (*,*) "sig1 = ", sig1
23443 !       write (*,*) "sig1 = ", sig1
23444 !       write (*,*) "sig2 = ", sig2
23445 ! alpha factors from Fcav/Gcav
23446           alf1   = 0.0d0
23447           alf2   = 0.0d0
23448           alf12  = 0.0d0
23449           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
23450
23451           b1 = alphasur_scpho(1,itypi)
23452 !          b1=0.0d0
23453           b2 = alphasur_scpho(2,itypi)
23454           b3 = alphasur_scpho(3,itypi)
23455           b4 = alphasur_scpho(4,itypi)
23456 ! used to determine whether we want to do quadrupole calculations
23457 ! used by Fgb
23458        eps_in = epsintab_scpho(itypi)
23459        if (eps_in.eq.0.0) eps_in=1.0
23460        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23461 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23462 !-------------------------------------------------------------------
23463 ! tail location and distance calculations
23464           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
23465           d1j = 0.0
23466        DO k = 1,3
23467 ! location of polar head is computed by taking hydrophobic centre
23468 ! and moving by a d1 * dc_norm vector
23469 ! see unres publications for very informative images
23470         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23471         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
23472 ! distance
23473 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23474 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23475         Rhead_distance(k) = chead(k,2) - chead(k,1)
23476        END DO
23477 ! pitagoras (root of sum of squares)
23478        Rhead = dsqrt( &
23479           (Rhead_distance(1)*Rhead_distance(1)) &
23480         + (Rhead_distance(2)*Rhead_distance(2)) &
23481         + (Rhead_distance(3)*Rhead_distance(3)))
23482        Rhead_sq=Rhead**2.0
23483 !-------------------------------------------------------------------
23484 ! zero everything that should be zero'ed
23485        evdwij = 0.0d0
23486        ECL = 0.0d0
23487        Elj = 0.0d0
23488        Equad = 0.0d0
23489        Epol = 0.0d0
23490        Fcav=0.0d0
23491        eheadtail = 0.0d0
23492        dGCLdR=0.0d0
23493        dGCLdOM1 = 0.0d0
23494        dGCLdOM2 = 0.0d0
23495        dGCLdOM12 = 0.0d0
23496        dPOLdOM1 = 0.0d0
23497        dPOLdOM2 = 0.0d0
23498           Fcav = 0.0d0
23499           dFdR = 0.0d0
23500           dCAVdOM1  = 0.0d0
23501           dCAVdOM2  = 0.0d0
23502           dCAVdOM12 = 0.0d0
23503           dscj_inv = vbld_inv(j+1)/2.0
23504 !dhead_scbasej(itypi,itypj)
23505 !          print *,i,j,dscj_inv,dsci_inv
23506 ! rij holds 1/(distance of Calpha atoms)
23507           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23508           rij  = dsqrt(rrij)
23509 !----------------------------
23510           CALL sc_angular
23511 ! this should be in elgrad_init but om's are calculated by sc_angular
23512 ! which in turn is used by older potentials
23513 ! om = omega, sqom = om^2
23514           sqom1  = om1 * om1
23515           sqom2  = om2 * om2
23516           sqom12 = om12 * om12
23517
23518 ! now we calculate EGB - Gey-Berne
23519 ! It will be summed up in evdwij and saved in evdw
23520           sigsq     = 1.0D0  / sigsq
23521           sig       = sig0ij * dsqrt(sigsq)
23522 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23523           rij_shift = 1.0/rij - sig + sig0ij
23524           IF (rij_shift.le.0.0D0) THEN
23525            evdw = 1.0D20
23526            RETURN
23527           END IF
23528           sigder = -sig * sigsq
23529           rij_shift = 1.0D0 / rij_shift
23530           fac       = rij_shift**expon
23531           c1        = fac  * fac * aa_scpho(itypi)
23532 !          c1        = 0.0d0
23533           c2        = fac  * bb_scpho(itypi)
23534 !          c2        = 0.0d0
23535           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23536           eps2der   = eps3rt * evdwij
23537           eps3der   = eps2rt * evdwij
23538 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23539           evdwij    = eps2rt * eps3rt * evdwij
23540           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23541           fac    = -expon * (c1 + evdwij) * rij_shift
23542           sigder = fac * sigder
23543 !          fac    = rij * fac
23544 ! Calculate distance derivative
23545           gg(1) =  fac
23546           gg(2) =  fac
23547           gg(3) =  fac
23548           fac = chis1 * sqom1 + chis2 * sqom2 &
23549           - 2.0d0 * chis12 * om1 * om2 * om12
23550 ! we will use pom later in Gcav, so dont mess with it!
23551           pom = 1.0d0 - chis1 * chis2 * sqom12
23552           Lambf = (1.0d0 - (fac / pom))
23553           Lambf = dsqrt(Lambf)
23554           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23555 !       write (*,*) "sparrow = ", sparrow
23556           Chif = 1.0d0/rij * sparrow
23557           ChiLambf = Chif * Lambf
23558           eagle = dsqrt(ChiLambf)
23559           bat = ChiLambf ** 11.0d0
23560           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23561           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23562           botsq = bot * bot
23563           Fcav = top / bot
23564           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23565           dbot = 12.0d0 * b4 * bat * Lambf
23566           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23567 !       dFdR = 0.0d0
23568 !      write (*,*) "dFcav/dR = ", dFdR
23569           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23570           dbot = 12.0d0 * b4 * bat * Chif
23571           eagle = Lambf * pom
23572           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23573           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23574           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23575               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23576
23577           dFdL = ((dtop * bot - top * dbot) / botsq)
23578 !       dFdL = 0.0d0
23579           dCAVdOM1  = dFdL * ( dFdOM1 )
23580           dCAVdOM2  = dFdL * ( dFdOM2 )
23581           dCAVdOM12 = dFdL * ( dFdOM12 )
23582
23583           ertail(1) = xj*rij
23584           ertail(2) = yj*rij
23585           ertail(3) = zj*rij
23586        DO k = 1, 3
23587 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23588 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23589 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
23590
23591         pom = ertail(k)
23592 !        print *,pom,gg(k),dFdR
23593 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23594         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
23595                   - (( dFdR + gg(k) ) * pom)
23596 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23597 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23598 !     &             - ( dFdR * pom )
23599 !        pom = ertail(k)
23600 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23601 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
23602 !                  + (( dFdR + gg(k) ) * pom)
23603 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23604 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23605 !c!     &             + ( dFdR * pom )
23606
23607         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
23608                   - (( dFdR + gg(k) ) * ertail(k))
23609 !c!     &             - ( dFdR * ertail(k))
23610
23611         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
23612                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23613
23614         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
23615                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23616
23617 !c!     &             + ( dFdR * ertail(k))
23618
23619         gg(k) = 0.0d0
23620         ENDDO
23621 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23622 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23623 !      alphapol1 = alphapol_scpho(itypi)
23624        if (wqq_scpho(itypi).ne.0.0) then
23625        Qij=wqq_scpho(itypi)/eps_in
23626        alpha_sco=1.d0/alphi_scpho(itypi)
23627 !       Qij=0.0
23628        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
23629 !c! derivative of Ecl is Gcl...
23630        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
23631                 (Rhead*alpha_sco+1) ) / Rhead_sq
23632        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
23633        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
23634        w1        = wqdip_scpho(1,itypi)
23635        w2        = wqdip_scpho(2,itypi)
23636 !       w1=0.0d0
23637 !       w2=0.0d0
23638 !       pis       = sig0head_scbase(itypi,itypj)
23639 !       eps_head   = epshead_scbase(itypi,itypj)
23640 !c!-------------------------------------------------------------------
23641
23642 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23643 !c!     &        +dhead(1,1,itypi,itypj))**2))
23644 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23645 !c!     &        +dhead(2,1,itypi,itypj))**2))
23646
23647 !c!-------------------------------------------------------------------
23648 !c! ecl
23649        sparrow  = w1  *  om1
23650        hawk     = w2 *  (1.0d0 - sqom2)
23651        Ecl = sparrow / Rhead**2.0d0 &
23652            - hawk    / Rhead**4.0d0
23653 !c!-------------------------------------------------------------------
23654        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
23655            1.0/rij,sparrow
23656
23657 !c! derivative of ecl is Gcl
23658 !c! dF/dr part
23659        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23660                 + 4.0d0 * hawk    / Rhead**5.0d0
23661 !c! dF/dom1
23662        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23663 !c! dF/dom2
23664        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23665        endif
23666
23667 !c--------------------------------------------------------------------
23668 !c Polarization energy
23669 !c Epol
23670        R1 = 0.0d0
23671        DO k = 1, 3
23672 !c! Calculate head-to-tail distances tail is center of side-chain
23673         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
23674        END DO
23675 !c! Pitagoras
23676        R1 = dsqrt(R1)
23677
23678       alphapol1 = alphapol_scpho(itypi)
23679 !      alphapol1=0.0
23680        MomoFac1 = (1.0d0 - chi2 * sqom1)
23681        RR1  = R1 * R1 / MomoFac1
23682        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23683 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
23684        fgb1 = sqrt( RR1 + a12sq * ee1)
23685 !       eps_inout_fac=0.0d0
23686        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23687 ! derivative of Epol is Gpol...
23688        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23689                 / (fgb1 ** 5.0d0)
23690        dFGBdR1 = ( (R1 / MomoFac1) &
23691              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23692              / ( 2.0d0 * fgb1 )
23693        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23694                * (2.0d0 - 0.5d0 * ee1) ) &
23695                / (2.0d0 * fgb1)
23696        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23697 !       dPOLdR1 = 0.0d0
23698 !       dPOLdOM1 = 0.0d0
23699        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
23700                * (2.0d0 - 0.5d0 * ee1) ) &
23701                / (2.0d0 * fgb1)
23702
23703        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
23704        dPOLdOM2 = 0.0
23705        DO k = 1, 3
23706         erhead(k) = Rhead_distance(k)/Rhead
23707         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
23708        END DO
23709
23710        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23711        erdxj = scalar( erhead(1), dC_norm(1,j) )
23712        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23713 !       bat=0.0d0
23714        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
23715        facd1 = d1i * vbld_inv(i+nres)
23716        facd2 = d1j * vbld_inv(j)
23717 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23718
23719        DO k = 1, 3
23720         hawk = (erhead_tail(k,1) + &
23721         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23722 !        facd1=0.0d0
23723 !        facd2=0.0d0
23724 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
23725 !                pom,(erhead_tail(k,1))
23726
23727 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
23728         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23729         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
23730                    - dGCLdR * pom &
23731                    - dPOLdR1 *  (erhead_tail(k,1))
23732 !     &             - dGLJdR * pom
23733
23734         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
23735 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
23736 !                   + dGCLdR * pom  &
23737 !                   + dPOLdR1 * (erhead_tail(k,1))
23738 !     &             + dGLJdR * pom
23739
23740
23741         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
23742                   - dGCLdR * erhead(k) &
23743                   - dPOLdR1 * erhead_tail(k,1)
23744 !     &             - dGLJdR * erhead(k)
23745
23746         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
23747                   + (dGCLdR * erhead(k)  &
23748                   + dPOLdR1 * erhead_tail(k,1))/2.0
23749         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
23750                   + (dGCLdR * erhead(k)  &
23751                   + dPOLdR1 * erhead_tail(k,1))/2.0
23752
23753 !     &             + dGLJdR * erhead(k)
23754 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
23755
23756        END DO
23757 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
23758        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
23759         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
23760        escpho=escpho+evdwij+epol+Fcav+ECL
23761        call sc_grad_scpho
23762          enddo
23763
23764       enddo
23765
23766       return
23767       end subroutine eprot_sc_phosphate
23768       SUBROUTINE sc_grad_scpho
23769       use calc_data
23770
23771        real (kind=8) :: dcosom1(3),dcosom2(3)
23772        eom1  =    &
23773               eps2der * eps2rt_om1   &
23774             - 2.0D0 * alf1 * eps3der &
23775             + sigder * sigsq_om1     &
23776             + dCAVdOM1               &
23777             + dGCLdOM1               &
23778             + dPOLdOM1
23779
23780        eom2  =  &
23781               eps2der * eps2rt_om2   &
23782             + 2.0D0 * alf2 * eps3der &
23783             + sigder * sigsq_om2     &
23784             + dCAVdOM2               &
23785             + dGCLdOM2               &
23786             + dPOLdOM2
23787
23788        eom12 =    &
23789               evdwij  * eps1_om12     &
23790             + eps2der * eps2rt_om12   &
23791             - 2.0D0 * alf12 * eps3der &
23792             + sigder *sigsq_om12      &
23793             + dCAVdOM12               &
23794             + dGCLdOM12
23795 !        om12=0.0
23796 !        eom12=0.0
23797 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23798 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
23799 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23800 !                 *dsci_inv*2.0
23801 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23802 !               gg(1),gg(2),"rozne"
23803        DO k = 1, 3
23804         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23805         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
23806         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23807         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
23808                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
23809                  *dscj_inv*2.0 &
23810                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23811         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
23812                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
23813                  *dscj_inv*2.0 &
23814                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23815         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
23816                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
23817                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23818
23819 !         print *,eom12,eom2,om12,om2
23820 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23821 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23822 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
23823 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23824 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23825         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
23826        END DO
23827        RETURN
23828       END SUBROUTINE sc_grad_scpho
23829       subroutine eprot_pep_phosphate(epeppho)
23830       use calc_data
23831 !      implicit real*8 (a-h,o-z)
23832 !      include 'DIMENSIONS'
23833 !      include 'COMMON.GEO'
23834 !      include 'COMMON.VAR'
23835 !      include 'COMMON.LOCAL'
23836 !      include 'COMMON.CHAIN'
23837 !      include 'COMMON.DERIV'
23838 !      include 'COMMON.NAMES'
23839 !      include 'COMMON.INTERACT'
23840 !      include 'COMMON.IOUNITS'
23841 !      include 'COMMON.CALC'
23842 !      include 'COMMON.CONTROL'
23843 !      include 'COMMON.SBRIDGE'
23844       logical :: lprn
23845 !el local variables
23846       integer :: iint,itypi,itypi1,itypj,subchap
23847       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23848       real(kind=8) :: evdw,sig0ij
23849       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23850                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23851                     sslipi,sslipj,faclip
23852       integer :: ii
23853       real(kind=8) :: fracinbuf
23854        real (kind=8) :: epeppho
23855        real (kind=8),dimension(4):: ener
23856        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23857        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23858         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23859         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23860         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23861         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23862         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23863         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23864        real(kind=8),dimension(3,2)::chead,erhead_tail
23865        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23866        integer troll
23867        real (kind=8) :: dcosom1(3),dcosom2(3)
23868        epeppho=0.0d0
23869 !       do i=1,nres_molec(1)
23870         do i=ibond_start,ibond_end
23871         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23872         itypi  = itype(i,1)
23873         dsci_inv = vbld_inv(i+1)/2.0
23874         dxi    = dc_norm(1,i)
23875         dyi    = dc_norm(2,i)
23876         dzi    = dc_norm(3,i)
23877         xi=(c(1,i)+c(1,i+1))/2.0
23878         yi=(c(2,i)+c(2,i+1))/2.0
23879         zi=(c(3,i)+c(3,i+1))/2.0
23880         xi=mod(xi,boxxsize)
23881          if (xi.lt.0) xi=xi+boxxsize
23882         yi=mod(yi,boxysize)
23883          if (yi.lt.0) yi=yi+boxysize
23884         zi=mod(zi,boxzsize)
23885          if (zi.lt.0) zi=zi+boxzsize
23886          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23887            itypj= itype(j,2)
23888            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23889             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23890            xj=(c(1,j)+c(1,j+1))/2.0
23891            yj=(c(2,j)+c(2,j+1))/2.0
23892            zj=(c(3,j)+c(3,j+1))/2.0
23893            xj=dmod(xj,boxxsize)
23894            if (xj.lt.0) xj=xj+boxxsize
23895            yj=dmod(yj,boxysize)
23896            if (yj.lt.0) yj=yj+boxysize
23897            zj=dmod(zj,boxzsize)
23898            if (zj.lt.0) zj=zj+boxzsize
23899           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23900           xj_safe=xj
23901           yj_safe=yj
23902           zj_safe=zj
23903           subchap=0
23904           do xshift=-1,1
23905           do yshift=-1,1
23906           do zshift=-1,1
23907           xj=xj_safe+xshift*boxxsize
23908           yj=yj_safe+yshift*boxysize
23909           zj=zj_safe+zshift*boxzsize
23910           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23911           if(dist_temp.lt.dist_init) then
23912             dist_init=dist_temp
23913             xj_temp=xj
23914             yj_temp=yj
23915             zj_temp=zj
23916             subchap=1
23917           endif
23918           enddo
23919           enddo
23920           enddo
23921           if (subchap.eq.1) then
23922           xj=xj_temp-xi
23923           yj=yj_temp-yi
23924           zj=zj_temp-zi
23925           else
23926           xj=xj_safe-xi
23927           yj=yj_safe-yi
23928           zj=zj_safe-zi
23929           endif
23930           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23931           rij  = dsqrt(rrij)
23932           dxj = dc_norm( 1,j )
23933           dyj = dc_norm( 2,j )
23934           dzj = dc_norm( 3,j )
23935           dscj_inv = vbld_inv(j+1)/2.0
23936 ! Gay-berne var's
23937           sig0ij = sigma_peppho
23938           chi1=0.0d0
23939           chi2=0.0d0
23940           chi12  = chi1 * chi2
23941           chip1=0.0d0
23942           chip2=0.0d0
23943           chip12 = chip1 * chip2
23944           chis1 = 0.0d0
23945           chis2 = 0.0d0
23946           chis12 = chis1 * chis2
23947           sig1 = sigmap1_peppho
23948           sig2 = sigmap2_peppho
23949 !       write (*,*) "sig1 = ", sig1
23950 !       write (*,*) "sig1 = ", sig1
23951 !       write (*,*) "sig2 = ", sig2
23952 ! alpha factors from Fcav/Gcav
23953           alf1   = 0.0d0
23954           alf2   = 0.0d0
23955           alf12  = 0.0d0
23956           b1 = alphasur_peppho(1)
23957 !          b1=0.0d0
23958           b2 = alphasur_peppho(2)
23959           b3 = alphasur_peppho(3)
23960           b4 = alphasur_peppho(4)
23961           CALL sc_angular
23962        sqom1=om1*om1
23963        evdwij = 0.0d0
23964        ECL = 0.0d0
23965        Elj = 0.0d0
23966        Equad = 0.0d0
23967        Epol = 0.0d0
23968        Fcav=0.0d0
23969        eheadtail = 0.0d0
23970        dGCLdR=0.0d0
23971        dGCLdOM1 = 0.0d0
23972        dGCLdOM2 = 0.0d0
23973        dGCLdOM12 = 0.0d0
23974        dPOLdOM1 = 0.0d0
23975        dPOLdOM2 = 0.0d0
23976           Fcav = 0.0d0
23977           dFdR = 0.0d0
23978           dCAVdOM1  = 0.0d0
23979           dCAVdOM2  = 0.0d0
23980           dCAVdOM12 = 0.0d0
23981           rij_shift = rij
23982           fac       = rij_shift**expon
23983           c1        = fac  * fac * aa_peppho
23984 !          c1        = 0.0d0
23985           c2        = fac  * bb_peppho
23986 !          c2        = 0.0d0
23987           evdwij    =  c1 + c2
23988 ! Now cavity....................
23989        eagle = dsqrt(1.0/rij_shift)
23990        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
23991           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
23992           botsq = bot * bot
23993           Fcav = top / bot
23994           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
23995           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
23996           dFdR = ((dtop * bot - top * dbot) / botsq)
23997        w1        = wqdip_peppho(1)
23998        w2        = wqdip_peppho(2)
23999 !       w1=0.0d0
24000 !       w2=0.0d0
24001 !       pis       = sig0head_scbase(itypi,itypj)
24002 !       eps_head   = epshead_scbase(itypi,itypj)
24003 !c!-------------------------------------------------------------------
24004
24005 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24006 !c!     &        +dhead(1,1,itypi,itypj))**2))
24007 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24008 !c!     &        +dhead(2,1,itypi,itypj))**2))
24009
24010 !c!-------------------------------------------------------------------
24011 !c! ecl
24012        sparrow  = w1  *  om1
24013        hawk     = w2 *  (1.0d0 - sqom1)
24014        Ecl = sparrow * rij_shift**2.0d0 &
24015            - hawk    * rij_shift**4.0d0
24016 !c!-------------------------------------------------------------------
24017 !c! derivative of ecl is Gcl
24018 !c! dF/dr part
24019 !       rij_shift=5.0
24020        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24021                 + 4.0d0 * hawk    * rij_shift**5.0d0
24022 !c! dF/dom1
24023        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24024 !c! dF/dom2
24025        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24026        eom1  =    dGCLdOM1+dGCLdOM2
24027        eom2  =    0.0
24028
24029           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24030 !          fac=0.0
24031           gg(1) =  fac*xj*rij
24032           gg(2) =  fac*yj*rij
24033           gg(3) =  fac*zj*rij
24034          do k=1,3
24035          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24036          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24037          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24038          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24039          gg(k)=0.0
24040          enddo
24041
24042       DO k = 1, 3
24043         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24044         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24045         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24046         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24047 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24048         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24049 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24050         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24051                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24052         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24053                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24054         enddo
24055        epeppho=epeppho+evdwij+Fcav+ECL
24056 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24057        enddo
24058        enddo
24059       end subroutine eprot_pep_phosphate
24060       end module energy