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        estr_nucl=0.0d0
 620        ebe_nucl=0.0d0
 621        evdwsb=0.0d0
 622        eelsb=0.0d0
 623        esbloc=0.0d0
 624       endif
 625       if (nfgtasks.gt.1) then
 626       if (fg_rank.eq.0) then
 627       call ecatcat(ecationcation)
 628       endif
 629       else
 630       call ecatcat(ecationcation)
 631       endif
 632       call ecat_prot(ecation_prot)
 633       if (nres_molec(2).gt.0) then
 634       call eprot_sc_base(escbase)
 635       call epep_sc_base(epepbase)
 636       call eprot_sc_phosphate(escpho)
 637       call eprot_pep_phosphate(epeppho)
 638       endif
 639 !      call ecatcat(ecationcation)
 640 !      print *,"after ebend", ebe_nucl
 641 #ifdef TIMING
 642       time_enecalc=time_enecalc+MPI_Wtime()-time00
 643 #endif
 644 !      print *,"Processor",myrank," computed Uconstr"
 645 #ifdef TIMING
 646       time00=MPI_Wtime()
 647 #endif
 648 !
 649 ! Sum the energies
 650 !
 651       energia(1)=evdw
 652 #ifdef SCP14
 653       energia(2)=evdw2-evdw2_14
 654       energia(18)=evdw2_14
 655 #else
 656       energia(2)=evdw2
 657       energia(18)=0.0d0
 658 #endif
 659 #ifdef SPLITELE
 660       energia(3)=ees
 661       energia(16)=evdw1
 662 #else
 663       energia(3)=ees+evdw1
 664       energia(16)=0.0d0
 665 #endif
 666       energia(4)=ecorr
 667       energia(5)=ecorr5
 668       energia(6)=ecorr6
 669       energia(7)=eel_loc
 670       energia(8)=eello_turn3
 671       energia(9)=eello_turn4
 672       energia(10)=eturn6
 673       energia(11)=ebe
 674       energia(12)=escloc
 675       energia(13)=etors
 676       energia(14)=etors_d
 677       energia(15)=ehpb
 678       energia(19)=edihcnstr
 679       energia(17)=estr
 680       energia(20)=Uconst+Uconst_back
 681       energia(21)=esccor
 682       energia(22)=eliptran
 683       energia(23)=Eafmforce
 684       energia(24)=ethetacnstr
 685       energia(25)=etube
 686 !---------------------------------------------------------------
 687       energia(26)=evdwpp
 688       energia(27)=eespp
 689       energia(28)=evdwpsb
 690       energia(29)=eelpsb
 691       energia(30)=evdwsb
 692       energia(31)=eelsb
 693       energia(32)=estr_nucl
 694       energia(33)=ebe_nucl
 695       energia(34)=esbloc
 696       energia(35)=etors_nucl
 697       energia(36)=etors_d_nucl
 698       energia(37)=ecorr_nucl
 699       energia(38)=ecorr3_nucl
 700 !----------------------------------------------------------------------
 701 !    Here are the energies showed per procesor if the are more processors
 702 !    per molecule then we sum it up in sum_energy subroutine
 703 !      print *," Processor",myrank," calls SUM_ENERGY"
 704       energia(41)=ecation_prot
 705       energia(42)=ecationcation
 706       energia(46)=escbase
 707       energia(47)=epepbase
 708       energia(48)=escpho
 709       energia(49)=epeppho
 710       call sum_energy(energia,.true.)
 711       if (dyn_ss) call dyn_set_nss
 712 !      print *," Processor",myrank," left SUM_ENERGY"
 713 #ifdef TIMING
 714       time_sumene=time_sumene+MPI_Wtime()-time00
 715 #endif
 716 !el        call enerprint(energia)
 717 !elwrite(iout,*)"finish etotal"
 718       return
 719       end subroutine etotal
 720 !-----------------------------------------------------------------------------
 721       subroutine sum_energy(energia,reduce)
 722 !      implicit real*8 (a-h,o-z)
 723 !      include 'DIMENSIONS'
 724 #ifndef ISNAN
 725       external proc_proc
 726 #ifdef WINPGI
 727 !MS$ATTRIBUTES C ::  proc_proc
 728 #endif
 729 #endif
 730 #ifdef MPI
 731       include "mpif.h"
 732 #endif
 733 !      include 'COMMON.SETUP'
 734 !      include 'COMMON.IOUNITS'
 735       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 736 !      include 'COMMON.FFIELD'
 737 !      include 'COMMON.DERIV'
 738 !      include 'COMMON.INTERACT'
 739 !      include 'COMMON.SBRIDGE'
 740 !      include 'COMMON.CHAIN'
 741 !      include 'COMMON.VAR'
 742 !      include 'COMMON.CONTROL'
 743 !      include 'COMMON.TIME1'
 744       logical :: reduce
 745       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 746       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 747       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 748         eliptran,etube, Eafmforce,ethetacnstr
 749       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 750                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 751                       ecorr3_nucl
 752       real(kind=8) :: ecation_prot,ecationcation
 753       real(kind=8) :: escbase,epepbase,escpho,epeppho
 754       integer :: i
 755 #ifdef MPI
 756       integer :: ierr
 757       real(kind=8) :: time00
 758       if (nfgtasks.gt.1 .and. reduce) then
 759
 760 #ifdef DEBUG
 761         write (iout,*) "energies before REDUCE"
 762         call enerprint(energia)
 763         call flush(iout)
 764 #endif
 765         do i=0,n_ene
 766           enebuff(i)=energia(i)
 767         enddo
 768         time00=MPI_Wtime()
 769         call MPI_Barrier(FG_COMM,IERR)
 770         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 771         time00=MPI_Wtime()
 772         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 773           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 774 #ifdef DEBUG
 775         write (iout,*) "energies after REDUCE"
 776         call enerprint(energia)
 777         call flush(iout)
 778 #endif
 779         time_Reduce=time_Reduce+MPI_Wtime()-time00
 780       endif
 781       if (fg_rank.eq.0) then
 782 #endif
 783       evdw=energia(1)
 784 #ifdef SCP14
 785       evdw2=energia(2)+energia(18)
 786       evdw2_14=energia(18)
 787 #else
 788       evdw2=energia(2)
 789 #endif
 790 #ifdef SPLITELE
 791       ees=energia(3)
 792       evdw1=energia(16)
 793 #else
 794       ees=energia(3)
 795       evdw1=0.0d0
 796 #endif
 797       ecorr=energia(4)
 798       ecorr5=energia(5)
 799       ecorr6=energia(6)
 800       eel_loc=energia(7)
 801       eello_turn3=energia(8)
 802       eello_turn4=energia(9)
 803       eturn6=energia(10)
 804       ebe=energia(11)
 805       escloc=energia(12)
 806       etors=energia(13)
 807       etors_d=energia(14)
 808       ehpb=energia(15)
 809       edihcnstr=energia(19)
 810       estr=energia(17)
 811       Uconst=energia(20)
 812       esccor=energia(21)
 813       eliptran=energia(22)
 814       Eafmforce=energia(23)
 815       ethetacnstr=energia(24)
 816       etube=energia(25)
 817       evdwpp=energia(26)
 818       eespp=energia(27)
 819       evdwpsb=energia(28)
 820       eelpsb=energia(29)
 821       evdwsb=energia(30)
 822       eelsb=energia(31)
 823       estr_nucl=energia(32)
 824       ebe_nucl=energia(33)
 825       esbloc=energia(34)
 826       etors_nucl=energia(35)
 827       etors_d_nucl=energia(36)
 828       ecorr_nucl=energia(37)
 829       ecorr3_nucl=energia(38)
 830       ecation_prot=energia(41)
 831       ecationcation=energia(42)
 832       escbase=energia(46)
 833       epepbase=energia(47)
 834       escpho=energia(48)
 835       epeppho=energia(49)
 836 !      energia(41)=ecation_prot
 837 !      energia(42)=ecationcation
 838
 839
 840 #ifdef SPLITELE
 841       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 842        +wang*ebe+wtor*etors+wscloc*escloc &
 843        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 844        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 845        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 846        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 847        +Eafmforce+ethetacnstr  &
 848        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 849        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 850        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 851        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 852        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 853        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 854 #else
 855       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 856        +wang*ebe+wtor*etors+wscloc*escloc &
 857        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 858        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 859        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 860        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 861        +Eafmforce+ethetacnstr &
 862        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 863        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 864        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 865        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 866        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 867        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 868 #endif
 869       energia(0)=etot
 870 ! detecting NaNQ
 871 #ifdef ISNAN
 872 #ifdef AIX
 873       if (isnan(etot).ne.0) energia(0)=1.0d+99
 874 #else
 875       if (isnan(etot)) energia(0)=1.0d+99
 876 #endif
 877 #else
 878       i=0
 879 #ifdef WINPGI
 880       idumm=proc_proc(etot,i)
 881 #else
 882       call proc_proc(etot,i)
 883 #endif
 884       if(i.eq.1)energia(0)=1.0d+99
 885 #endif
 886 #ifdef MPI
 887       endif
 888 #endif
 889 !      call enerprint(energia)
 890       call flush(iout)
 891       return
 892       end subroutine sum_energy
 893 !-----------------------------------------------------------------------------
 894       subroutine rescale_weights(t_bath)
 895 !      implicit real*8 (a-h,o-z)
 896 #ifdef MPI
 897       include 'mpif.h'
 898 #endif
 899 !      include 'DIMENSIONS'
 900 !      include 'COMMON.IOUNITS'
 901 !      include 'COMMON.FFIELD'
 902 !      include 'COMMON.SBRIDGE'
 903       real(kind=8) :: kfac=2.4d0
 904       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 905 !el local variables
 906       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 907       real(kind=8) :: T0=3.0d2
 908       integer :: ierror
 909 !      facT=temp0/t_bath
 910 !      facT=2*temp0/(t_bath+temp0)
 911       if (rescale_mode.eq.0) then
 912         facT(1)=1.0d0
 913         facT(2)=1.0d0
 914         facT(3)=1.0d0
 915         facT(4)=1.0d0
 916         facT(5)=1.0d0
 917         facT(6)=1.0d0
 918       else if (rescale_mode.eq.1) then
 919         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 920         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 921         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 922         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 923         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 924 #ifdef WHAM_RUN
 925 !#if defined(WHAM_RUN) || defined(CLUSTER)
 926 #if defined(FUNCTH)
 927 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 928         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 929 #elif defined(FUNCT)
 930         facT(6)=t_bath/T0
 931 #else
 932         facT(6)=1.0d0
 933 #endif
 934 #endif
 935       else if (rescale_mode.eq.2) then
 936         x=t_bath/temp0
 937         x2=x*x
 938         x3=x2*x
 939         x4=x3*x
 940         x5=x4*x
 941         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 942         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 943         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 944         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 945         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 946 #ifdef WHAM_RUN
 947 !#if defined(WHAM_RUN) || defined(CLUSTER)
 948 #if defined(FUNCTH)
 949         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 950 #elif defined(FUNCT)
 951         facT(6)=t_bath/T0
 952 #else
 953         facT(6)=1.0d0
 954 #endif
 955 #endif
 956       else
 957         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 958         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 959 #ifdef MPI
 960        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 961 #endif
 962        stop 555
 963       endif
 964       welec=weights(3)*fact(1)
 965       wcorr=weights(4)*fact(3)
 966       wcorr5=weights(5)*fact(4)
 967       wcorr6=weights(6)*fact(5)
 968       wel_loc=weights(7)*fact(2)
 969       wturn3=weights(8)*fact(2)
 970       wturn4=weights(9)*fact(3)
 971       wturn6=weights(10)*fact(5)
 972       wtor=weights(13)*fact(1)
 973       wtor_d=weights(14)*fact(2)
 974       wsccor=weights(21)*fact(1)
 975
 976       return
 977       end subroutine rescale_weights
 978 !-----------------------------------------------------------------------------
 979       subroutine enerprint(energia)
 980 !      implicit real*8 (a-h,o-z)
 981 !      include 'DIMENSIONS'
 982 !      include 'COMMON.IOUNITS'
 983 !      include 'COMMON.FFIELD'
 984 !      include 'COMMON.SBRIDGE'
 985 !      include 'COMMON.MD'
 986       real(kind=8) :: energia(0:n_ene)
 987 !el local variables
 988       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 989       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 990       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 991        etube,ethetacnstr,Eafmforce
 992       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 993                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 994                       ecorr3_nucl
 995       real(kind=8) :: ecation_prot,ecationcation
 996       real(kind=8) :: escbase,epepbase,escpho,epeppho
 997
 998       etot=energia(0)
 999       evdw=energia(1)
1000       evdw2=energia(2)
1001 #ifdef SCP14
1002       evdw2=energia(2)+energia(18)
1003 #else
1004       evdw2=energia(2)
1005 #endif
1006       ees=energia(3)
1007 #ifdef SPLITELE
1008       evdw1=energia(16)
1009 #endif
1010       ecorr=energia(4)
1011       ecorr5=energia(5)
1012       ecorr6=energia(6)
1013       eel_loc=energia(7)
1014       eello_turn3=energia(8)
1015       eello_turn4=energia(9)
1016       eello_turn6=energia(10)
1017       ebe=energia(11)
1018       escloc=energia(12)
1019       etors=energia(13)
1020       etors_d=energia(14)
1021       ehpb=energia(15)
1022       edihcnstr=energia(19)
1023       estr=energia(17)
1024       Uconst=energia(20)
1025       esccor=energia(21)
1026       eliptran=energia(22)
1027       Eafmforce=energia(23)
1028       ethetacnstr=energia(24)
1029       etube=energia(25)
1030       evdwpp=energia(26)
1031       eespp=energia(27)
1032       evdwpsb=energia(28)
1033       eelpsb=energia(29)
1034       evdwsb=energia(30)
1035       eelsb=energia(31)
1036       estr_nucl=energia(32)
1037       ebe_nucl=energia(33)
1038       esbloc=energia(34)
1039       etors_nucl=energia(35)
1040       etors_d_nucl=energia(36)
1041       ecorr_nucl=energia(37)
1042       ecorr3_nucl=energia(38)
1043       ecation_prot=energia(41)
1044       ecationcation=energia(42)
1045       escbase=energia(46)
1046       epepbase=energia(47)
1047       escpho=energia(48)
1048       epeppho=energia(49)
1049 #ifdef SPLITELE
1050       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1051         estr,wbond,ebe,wang,&
1052         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1053         ecorr,wcorr,&
1054         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1055         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1056         edihcnstr,ethetacnstr,ebr*nss,&
1057         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1058         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1059         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1060         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1061         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1062         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1063         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1064         etot
1065    10 format (/'Virtual-chain energies:'// &
1066        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1067        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1068        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1069        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1070        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1071        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1072        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1073        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1074        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1075        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1076        ' (SS bridges & dist. cnstr.)'/ &
1077        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1078        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1079        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1080        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1081        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1082        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1083        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1084        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1085        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1086        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1087        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1088        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1089        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1090        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1091        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1092        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1093        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1094        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1095        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1096        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1097        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1098        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1099        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1100        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1101        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1102        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1103        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1104        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1105        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1106        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1107        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1108        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1109        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1110        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1111        'ETOT=  ',1pE16.6,' (total)')
1112 #else
1113       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1114         estr,wbond,ebe,wang,&
1115         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1116         ecorr,wcorr,&
1117         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1118         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1119         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1120         etube,wtube, &
1121         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1122         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1123         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1124         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1125         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1126         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1127         etot
1128    10 format (/'Virtual-chain energies:'// &
1129        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1130        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1131        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1132        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1133        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1134        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1135        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1136        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1137        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1138        ' (SS bridges & dist. cnstr.)'/ &
1139        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1140        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1141        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1142        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1143        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1144        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1145        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1146        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1147        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1148        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1149        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1150        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1151        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1152        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1153        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1154        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1155        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1156        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1157        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1158        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1159        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1160        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1161        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1162        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1163        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1164        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1165        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1166        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1167        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1168        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1169        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1170        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1171        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1172        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1173        'ETOT=  ',1pE16.6,' (total)')
1174 #endif
1175       return
1176       end subroutine enerprint
1177 !-----------------------------------------------------------------------------
1178       subroutine elj(evdw)
1179 !
1180 ! This subroutine calculates the interaction energy of nonbonded side chains
1181 ! assuming the LJ potential of interaction.
1182 !
1183 !      implicit real*8 (a-h,o-z)
1184 !      include 'DIMENSIONS'
1185       real(kind=8),parameter :: accur=1.0d-10
1186 !      include 'COMMON.GEO'
1187 !      include 'COMMON.VAR'
1188 !      include 'COMMON.LOCAL'
1189 !      include 'COMMON.CHAIN'
1190 !      include 'COMMON.DERIV'
1191 !      include 'COMMON.INTERACT'
1192 !      include 'COMMON.TORSION'
1193 !      include 'COMMON.SBRIDGE'
1194 !      include 'COMMON.NAMES'
1195 !      include 'COMMON.IOUNITS'
1196 !      include 'COMMON.CONTACTS'
1197       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1198       integer :: num_conti
1199 !el local variables
1200       integer :: i,itypi,iint,j,itypi1,itypj,k
1201       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1202       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1203       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1204
1205 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1206       evdw=0.0D0
1207 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1208 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1209 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1210 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1211
1212       do i=iatsc_s,iatsc_e
1213         itypi=iabs(itype(i,1))
1214         if (itypi.eq.ntyp1) cycle
1215         itypi1=iabs(itype(i+1,1))
1216         xi=c(1,nres+i)
1217         yi=c(2,nres+i)
1218         zi=c(3,nres+i)
1219 ! Change 12/1/95
1220         num_conti=0
1221 !
1222 ! Calculate SC interaction energy.
1223 !
1224         do iint=1,nint_gr(i)
1225 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1226 !d   &                  'iend=',iend(i,iint)
1227           do j=istart(i,iint),iend(i,iint)
1228             itypj=iabs(itype(j,1))
1229             if (itypj.eq.ntyp1) cycle
1230             xj=c(1,nres+j)-xi
1231             yj=c(2,nres+j)-yi
1232             zj=c(3,nres+j)-zi
1233 ! Change 12/1/95 to calculate four-body interactions
1234             rij=xj*xj+yj*yj+zj*zj
1235             rrij=1.0D0/rij
1236 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1237             eps0ij=eps(itypi,itypj)
1238             fac=rrij**expon2
1239             e1=fac*fac*aa_aq(itypi,itypj)
1240             e2=fac*bb_aq(itypi,itypj)
1241             evdwij=e1+e2
1242 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1243 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1244 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1245 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1246 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1247 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1248             evdw=evdw+evdwij
1249 !
1250 ! Calculate the components of the gradient in DC and X
1251 !
1252             fac=-rrij*(e1+evdwij)
1253             gg(1)=xj*fac
1254             gg(2)=yj*fac
1255             gg(3)=zj*fac
1256             do k=1,3
1257               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1258               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1259               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1260               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1261             enddo
1262 !grad            do k=i,j-1
1263 !grad              do l=1,3
1264 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1265 !grad              enddo
1266 !grad            enddo
1267 !
1268 ! 12/1/95, revised on 5/20/97
1269 !
1270 ! Calculate the contact function. The ith column of the array JCONT will
1271 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1272 ! greater than I). The arrays FACONT and GACONT will contain the values of
1273 ! the contact function and its derivative.
1274 !
1275 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1276 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1277 ! Uncomment next line, if the correlation interactions are contact function only
1278             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1279               rij=dsqrt(rij)
1280               sigij=sigma(itypi,itypj)
1281               r0ij=rs0(itypi,itypj)
1282 !
1283 ! Check whether the SC's are not too far to make a contact.
1284 !
1285               rcut=1.5d0*r0ij
1286               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1287 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1288 !
1289               if (fcont.gt.0.0D0) then
1290 ! If the SC-SC distance if close to sigma, apply spline.
1291 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1292 !Adam &             fcont1,fprimcont1)
1293 !Adam           fcont1=1.0d0-fcont1
1294 !Adam           if (fcont1.gt.0.0d0) then
1295 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1296 !Adam             fcont=fcont*fcont1
1297 !Adam           endif
1298 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1299 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1300 !ga             do k=1,3
1301 !ga               gg(k)=gg(k)*eps0ij
1302 !ga             enddo
1303 !ga             eps0ij=-evdwij*eps0ij
1304 ! Uncomment for AL's type of SC correlation interactions.
1305 !adam           eps0ij=-evdwij
1306                 num_conti=num_conti+1
1307                 jcont(num_conti,i)=j
1308                 facont(num_conti,i)=fcont*eps0ij
1309                 fprimcont=eps0ij*fprimcont/rij
1310                 fcont=expon*fcont
1311 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1312 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1313 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1314 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1315                 gacont(1,num_conti,i)=-fprimcont*xj
1316                 gacont(2,num_conti,i)=-fprimcont*yj
1317                 gacont(3,num_conti,i)=-fprimcont*zj
1318 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1319 !d              write (iout,'(2i3,3f10.5)')
1320 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1321               endif
1322             endif
1323           enddo      ! j
1324         enddo        ! iint
1325 ! Change 12/1/95
1326         num_cont(i)=num_conti
1327       enddo          ! i
1328       do i=1,nct
1329         do j=1,3
1330           gvdwc(j,i)=expon*gvdwc(j,i)
1331           gvdwx(j,i)=expon*gvdwx(j,i)
1332         enddo
1333       enddo
1334 !******************************************************************************
1335 !
1336 !                              N O T E !!!
1337 !
1338 ! To save time, the factor of EXPON has been extracted from ALL components
1339 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1340 ! use!
1341 !
1342 !******************************************************************************
1343       return
1344       end subroutine elj
1345 !-----------------------------------------------------------------------------
1346       subroutine eljk(evdw)
1347 !
1348 ! This subroutine calculates the interaction energy of nonbonded side chains
1349 ! assuming the LJK potential of interaction.
1350 !
1351 !      implicit real*8 (a-h,o-z)
1352 !      include 'DIMENSIONS'
1353 !      include 'COMMON.GEO'
1354 !      include 'COMMON.VAR'
1355 !      include 'COMMON.LOCAL'
1356 !      include 'COMMON.CHAIN'
1357 !      include 'COMMON.DERIV'
1358 !      include 'COMMON.INTERACT'
1359 !      include 'COMMON.IOUNITS'
1360 !      include 'COMMON.NAMES'
1361       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1362       logical :: scheck
1363 !el local variables
1364       integer :: i,iint,j,itypi,itypi1,k,itypj
1365       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1366       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1367
1368 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1369       evdw=0.0D0
1370       do i=iatsc_s,iatsc_e
1371         itypi=iabs(itype(i,1))
1372         if (itypi.eq.ntyp1) cycle
1373         itypi1=iabs(itype(i+1,1))
1374         xi=c(1,nres+i)
1375         yi=c(2,nres+i)
1376         zi=c(3,nres+i)
1377 !
1378 ! Calculate SC interaction energy.
1379 !
1380         do iint=1,nint_gr(i)
1381           do j=istart(i,iint),iend(i,iint)
1382             itypj=iabs(itype(j,1))
1383             if (itypj.eq.ntyp1) cycle
1384             xj=c(1,nres+j)-xi
1385             yj=c(2,nres+j)-yi
1386             zj=c(3,nres+j)-zi
1387             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1388             fac_augm=rrij**expon
1389             e_augm=augm(itypi,itypj)*fac_augm
1390             r_inv_ij=dsqrt(rrij)
1391             rij=1.0D0/r_inv_ij
1392             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1393             fac=r_shift_inv**expon
1394             e1=fac*fac*aa_aq(itypi,itypj)
1395             e2=fac*bb_aq(itypi,itypj)
1396             evdwij=e_augm+e1+e2
1397 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1398 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1399 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1400 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1401 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1402 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1403 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1404             evdw=evdw+evdwij
1405 !
1406 ! Calculate the components of the gradient in DC and X
1407 !
1408             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1409             gg(1)=xj*fac
1410             gg(2)=yj*fac
1411             gg(3)=zj*fac
1412             do k=1,3
1413               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1414               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1415               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1416               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1417             enddo
1418 !grad            do k=i,j-1
1419 !grad              do l=1,3
1420 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1421 !grad              enddo
1422 !grad            enddo
1423           enddo      ! j
1424         enddo        ! iint
1425       enddo          ! i
1426       do i=1,nct
1427         do j=1,3
1428           gvdwc(j,i)=expon*gvdwc(j,i)
1429           gvdwx(j,i)=expon*gvdwx(j,i)
1430         enddo
1431       enddo
1432       return
1433       end subroutine eljk
1434 !-----------------------------------------------------------------------------
1435       subroutine ebp(evdw)
1436 !
1437 ! This subroutine calculates the interaction energy of nonbonded side chains
1438 ! assuming the Berne-Pechukas potential of interaction.
1439 !
1440       use comm_srutu
1441       use calc_data
1442 !      implicit real*8 (a-h,o-z)
1443 !      include 'DIMENSIONS'
1444 !      include 'COMMON.GEO'
1445 !      include 'COMMON.VAR'
1446 !      include 'COMMON.LOCAL'
1447 !      include 'COMMON.CHAIN'
1448 !      include 'COMMON.DERIV'
1449 !      include 'COMMON.NAMES'
1450 !      include 'COMMON.INTERACT'
1451 !      include 'COMMON.IOUNITS'
1452 !      include 'COMMON.CALC'
1453       use comm_srutu
1454 !el      integer :: icall
1455 !el      common /srutu/ icall
1456 !     double precision rrsave(maxdim)
1457       logical :: lprn
1458 !el local variables
1459       integer :: iint,itypi,itypi1,itypj
1460       real(kind=8) :: rrij,xi,yi,zi
1461       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1462
1463 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1464       evdw=0.0D0
1465 !     if (icall.eq.0) then
1466 !       lprn=.true.
1467 !     else
1468         lprn=.false.
1469 !     endif
1470 !el      ind=0
1471       do i=iatsc_s,iatsc_e
1472         itypi=iabs(itype(i,1))
1473         if (itypi.eq.ntyp1) cycle
1474         itypi1=iabs(itype(i+1,1))
1475         xi=c(1,nres+i)
1476         yi=c(2,nres+i)
1477         zi=c(3,nres+i)
1478         dxi=dc_norm(1,nres+i)
1479         dyi=dc_norm(2,nres+i)
1480         dzi=dc_norm(3,nres+i)
1481 !        dsci_inv=dsc_inv(itypi)
1482         dsci_inv=vbld_inv(i+nres)
1483 !
1484 ! Calculate SC interaction energy.
1485 !
1486         do iint=1,nint_gr(i)
1487           do j=istart(i,iint),iend(i,iint)
1488 !el            ind=ind+1
1489             itypj=iabs(itype(j,1))
1490             if (itypj.eq.ntyp1) cycle
1491 !            dscj_inv=dsc_inv(itypj)
1492             dscj_inv=vbld_inv(j+nres)
1493             chi1=chi(itypi,itypj)
1494             chi2=chi(itypj,itypi)
1495             chi12=chi1*chi2
1496             chip1=chip(itypi)
1497             chip2=chip(itypj)
1498             chip12=chip1*chip2
1499             alf1=alp(itypi)
1500             alf2=alp(itypj)
1501             alf12=0.5D0*(alf1+alf2)
1502 ! For diagnostics only!!!
1503 !           chi1=0.0D0
1504 !           chi2=0.0D0
1505 !           chi12=0.0D0
1506 !           chip1=0.0D0
1507 !           chip2=0.0D0
1508 !           chip12=0.0D0
1509 !           alf1=0.0D0
1510 !           alf2=0.0D0
1511 !           alf12=0.0D0
1512             xj=c(1,nres+j)-xi
1513             yj=c(2,nres+j)-yi
1514             zj=c(3,nres+j)-zi
1515             dxj=dc_norm(1,nres+j)
1516             dyj=dc_norm(2,nres+j)
1517             dzj=dc_norm(3,nres+j)
1518             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1519 !d          if (icall.eq.0) then
1520 !d            rrsave(ind)=rrij
1521 !d          else
1522 !d            rrij=rrsave(ind)
1523 !d          endif
1524             rij=dsqrt(rrij)
1525 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1526             call sc_angular
1527 ! Calculate whole angle-dependent part of epsilon and contributions
1528 ! to its derivatives
1529             fac=(rrij*sigsq)**expon2
1530             e1=fac*fac*aa_aq(itypi,itypj)
1531             e2=fac*bb_aq(itypi,itypj)
1532             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1533             eps2der=evdwij*eps3rt
1534             eps3der=evdwij*eps2rt
1535             evdwij=evdwij*eps2rt*eps3rt
1536             evdw=evdw+evdwij
1537             if (lprn) then
1538             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1539             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1540 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1541 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1542 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1543 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1544 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1545 !d     &        evdwij
1546             endif
1547 ! Calculate gradient components.
1548             e1=e1*eps1*eps2rt**2*eps3rt**2
1549             fac=-expon*(e1+evdwij)
1550             sigder=fac/sigsq
1551             fac=rrij*fac
1552 ! Calculate radial part of the gradient
1553             gg(1)=xj*fac
1554             gg(2)=yj*fac
1555             gg(3)=zj*fac
1556 ! Calculate the angular part of the gradient and sum add the contributions
1557 ! to the appropriate components of the Cartesian gradient.
1558             call sc_grad
1559           enddo      ! j
1560         enddo        ! iint
1561       enddo          ! i
1562 !     stop
1563       return
1564       end subroutine ebp
1565 !-----------------------------------------------------------------------------
1566       subroutine egb(evdw)
1567 !
1568 ! This subroutine calculates the interaction energy of nonbonded side chains
1569 ! assuming the Gay-Berne potential of interaction.
1570 !
1571       use calc_data
1572 !      implicit real*8 (a-h,o-z)
1573 !      include 'DIMENSIONS'
1574 !      include 'COMMON.GEO'
1575 !      include 'COMMON.VAR'
1576 !      include 'COMMON.LOCAL'
1577 !      include 'COMMON.CHAIN'
1578 !      include 'COMMON.DERIV'
1579 !      include 'COMMON.NAMES'
1580 !      include 'COMMON.INTERACT'
1581 !      include 'COMMON.IOUNITS'
1582 !      include 'COMMON.CALC'
1583 !      include 'COMMON.CONTROL'
1584 !      include 'COMMON.SBRIDGE'
1585       logical :: lprn
1586 !el local variables
1587       integer :: iint,itypi,itypi1,itypj,subchap
1588       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1589       real(kind=8) :: evdw,sig0ij
1590       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1591                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1592                     sslipi,sslipj,faclip
1593       integer :: ii
1594       real(kind=8) :: fracinbuf
1595
1596 !cccc      energy_dec=.false.
1597 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1598       evdw=0.0D0
1599       lprn=.false.
1600 !     if (icall.eq.0) lprn=.false.
1601 !el      ind=0
1602       do i=iatsc_s,iatsc_e
1603 !C        print *,"I am in EVDW",i
1604         itypi=iabs(itype(i,1))
1605 !        if (i.ne.47) cycle
1606         if (itypi.eq.ntyp1) cycle
1607         itypi1=iabs(itype(i+1,1))
1608         xi=c(1,nres+i)
1609         yi=c(2,nres+i)
1610         zi=c(3,nres+i)
1611           xi=dmod(xi,boxxsize)
1612           if (xi.lt.0) xi=xi+boxxsize
1613           yi=dmod(yi,boxysize)
1614           if (yi.lt.0) yi=yi+boxysize
1615           zi=dmod(zi,boxzsize)
1616           if (zi.lt.0) zi=zi+boxzsize
1617
1618        if ((zi.gt.bordlipbot)  &
1619         .and.(zi.lt.bordliptop)) then
1620 !C the energy transfer exist
1621         if (zi.lt.buflipbot) then
1622 !C what fraction I am in
1623          fracinbuf=1.0d0-  &
1624               ((zi-bordlipbot)/lipbufthick)
1625 !C lipbufthick is thickenes of lipid buffore
1626          sslipi=sscalelip(fracinbuf)
1627          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1628         elseif (zi.gt.bufliptop) then
1629          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1630          sslipi=sscalelip(fracinbuf)
1631          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1632         else
1633          sslipi=1.0d0
1634          ssgradlipi=0.0
1635         endif
1636        else
1637          sslipi=0.0d0
1638          ssgradlipi=0.0
1639        endif
1640 !       print *, sslipi,ssgradlipi
1641         dxi=dc_norm(1,nres+i)
1642         dyi=dc_norm(2,nres+i)
1643         dzi=dc_norm(3,nres+i)
1644 !        dsci_inv=dsc_inv(itypi)
1645         dsci_inv=vbld_inv(i+nres)
1646 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1647 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1648 !
1649 ! Calculate SC interaction energy.
1650 !
1651         do iint=1,nint_gr(i)
1652           do j=istart(i,iint),iend(i,iint)
1653             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1654               call dyn_ssbond_ene(i,j,evdwij)
1655               evdw=evdw+evdwij
1656               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1657                               'evdw',i,j,evdwij,' ss'
1658 !              if (energy_dec) write (iout,*) &
1659 !                              'evdw',i,j,evdwij,' ss'
1660              do k=j+1,iend(i,iint)
1661 !C search over all next residues
1662               if (dyn_ss_mask(k)) then
1663 !C check if they are cysteins
1664 !C              write(iout,*) 'k=',k
1665
1666 !c              write(iout,*) "PRZED TRI", evdwij
1667 !               evdwij_przed_tri=evdwij
1668               call triple_ssbond_ene(i,j,k,evdwij)
1669 !c               if(evdwij_przed_tri.ne.evdwij) then
1670 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1671 !c               endif
1672
1673 !c              write(iout,*) "PO TRI", evdwij
1674 !C call the energy function that removes the artifical triple disulfide
1675 !C bond the soubroutine is located in ssMD.F
1676               evdw=evdw+evdwij
1677               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1678                             'evdw',i,j,evdwij,'tss'
1679               endif!dyn_ss_mask(k)
1680              enddo! k
1681             ELSE
1682 !el            ind=ind+1
1683             itypj=iabs(itype(j,1))
1684             if (itypj.eq.ntyp1) cycle
1685 !             if (j.ne.78) cycle
1686 !            dscj_inv=dsc_inv(itypj)
1687             dscj_inv=vbld_inv(j+nres)
1688 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1689 !              1.0d0/vbld(j+nres) !d
1690 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1691             sig0ij=sigma(itypi,itypj)
1692             chi1=chi(itypi,itypj)
1693             chi2=chi(itypj,itypi)
1694             chi12=chi1*chi2
1695             chip1=chip(itypi)
1696             chip2=chip(itypj)
1697             chip12=chip1*chip2
1698             alf1=alp(itypi)
1699             alf2=alp(itypj)
1700             alf12=0.5D0*(alf1+alf2)
1701 ! For diagnostics only!!!
1702 !           chi1=0.0D0
1703 !           chi2=0.0D0
1704 !           chi12=0.0D0
1705 !           chip1=0.0D0
1706 !           chip2=0.0D0
1707 !           chip12=0.0D0
1708 !           alf1=0.0D0
1709 !           alf2=0.0D0
1710 !           alf12=0.0D0
1711            xj=c(1,nres+j)
1712            yj=c(2,nres+j)
1713            zj=c(3,nres+j)
1714           xj=dmod(xj,boxxsize)
1715           if (xj.lt.0) xj=xj+boxxsize
1716           yj=dmod(yj,boxysize)
1717           if (yj.lt.0) yj=yj+boxysize
1718           zj=dmod(zj,boxzsize)
1719           if (zj.lt.0) zj=zj+boxzsize
1720 !          print *,"tu",xi,yi,zi,xj,yj,zj
1721 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1722 ! this fragment set correct epsilon for lipid phase
1723        if ((zj.gt.bordlipbot)  &
1724        .and.(zj.lt.bordliptop)) then
1725 !C the energy transfer exist
1726         if (zj.lt.buflipbot) then
1727 !C what fraction I am in
1728          fracinbuf=1.0d0-     &
1729              ((zj-bordlipbot)/lipbufthick)
1730 !C lipbufthick is thickenes of lipid buffore
1731          sslipj=sscalelip(fracinbuf)
1732          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1733         elseif (zj.gt.bufliptop) then
1734          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1735          sslipj=sscalelip(fracinbuf)
1736          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1737         else
1738          sslipj=1.0d0
1739          ssgradlipj=0.0
1740         endif
1741        else
1742          sslipj=0.0d0
1743          ssgradlipj=0.0
1744        endif
1745       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1746        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1747       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1748        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1749 !------------------------------------------------
1750       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1751       xj_safe=xj
1752       yj_safe=yj
1753       zj_safe=zj
1754       subchap=0
1755       do xshift=-1,1
1756       do yshift=-1,1
1757       do zshift=-1,1
1758           xj=xj_safe+xshift*boxxsize
1759           yj=yj_safe+yshift*boxysize
1760           zj=zj_safe+zshift*boxzsize
1761           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1762           if(dist_temp.lt.dist_init) then
1763             dist_init=dist_temp
1764             xj_temp=xj
1765             yj_temp=yj
1766             zj_temp=zj
1767             subchap=1
1768           endif
1769        enddo
1770        enddo
1771        enddo
1772        if (subchap.eq.1) then
1773           xj=xj_temp-xi
1774           yj=yj_temp-yi
1775           zj=zj_temp-zi
1776        else
1777           xj=xj_safe-xi
1778           yj=yj_safe-yi
1779           zj=zj_safe-zi
1780        endif
1781             dxj=dc_norm(1,nres+j)
1782             dyj=dc_norm(2,nres+j)
1783             dzj=dc_norm(3,nres+j)
1784 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1785 !            write (iout,*) "j",j," dc_norm",& !d
1786 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1787 !          write(iout,*)"rrij ",rrij
1788 !          write(iout,*)"xj yj zj ", xj, yj, zj
1789 !          write(iout,*)"xi yi zi ", xi, yi, zi
1790 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1791             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1792             rij=dsqrt(rrij)
1793             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1794             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1795 !            print *,sss_ele_cut,sss_ele_grad,&
1796 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1797             if (sss_ele_cut.le.0.0) cycle
1798 ! Calculate angle-dependent terms of energy and contributions to their
1799 ! derivatives.
1800             call sc_angular
1801             sigsq=1.0D0/sigsq
1802             sig=sig0ij*dsqrt(sigsq)
1803             rij_shift=1.0D0/rij-sig+sig0ij
1804 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1805 !            "sig0ij",sig0ij
1806 ! for diagnostics; uncomment
1807 !            rij_shift=1.2*sig0ij
1808 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1809             if (rij_shift.le.0.0D0) then
1810               evdw=1.0D20
1811 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1812 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1813 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1814               return
1815             endif
1816             sigder=-sig*sigsq
1817 !---------------------------------------------------------------
1818             rij_shift=1.0D0/rij_shift
1819             fac=rij_shift**expon
1820             faclip=fac
1821             e1=fac*fac*aa!(itypi,itypj)
1822             e2=fac*bb!(itypi,itypj)
1823             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1824             eps2der=evdwij*eps3rt
1825             eps3der=evdwij*eps2rt
1826 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1827 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1828 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1829             evdwij=evdwij*eps2rt*eps3rt
1830             evdw=evdw+evdwij*sss_ele_cut
1831             if (lprn) then
1832             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1833             epsi=bb**2/aa!(itypi,itypj)
1834             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1835               restyp(itypi,1),i,restyp(itypj,1),j, &
1836               epsi,sigm,chi1,chi2,chip1,chip2, &
1837               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1838               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1839               evdwij
1840             endif
1841
1842             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1843                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1844 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1845 !            if (energy_dec) write (iout,*) &
1846 !                             'evdw',i,j,evdwij
1847 !                       print *,"ZALAMKA", evdw
1848
1849 ! Calculate gradient components.
1850             e1=e1*eps1*eps2rt**2*eps3rt**2
1851             fac=-expon*(e1+evdwij)*rij_shift
1852             sigder=fac*sigder
1853             fac=rij*fac
1854 !            print *,'before fac',fac,rij,evdwij
1855             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1856             /sigma(itypi,itypj)*rij
1857 !            print *,'grad part scale',fac,   &
1858 !             evdwij*sss_ele_grad/sss_ele_cut &
1859 !            /sigma(itypi,itypj)*rij
1860 !            fac=0.0d0
1861 ! Calculate the radial part of the gradient
1862             gg(1)=xj*fac
1863             gg(2)=yj*fac
1864             gg(3)=zj*fac
1865 !C Calculate the radial part of the gradient
1866             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1867        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1868         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1869        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1870             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1871             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1872
1873 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1874 ! Calculate angular part of the gradient.
1875             call sc_grad
1876             ENDIF    ! dyn_ss
1877           enddo      ! j
1878         enddo        ! iint
1879       enddo          ! i
1880 !       print *,"ZALAMKA", evdw
1881 !      write (iout,*) "Number of loop steps in EGB:",ind
1882 !ccc      energy_dec=.false.
1883       return
1884       end subroutine egb
1885 !-----------------------------------------------------------------------------
1886       subroutine egbv(evdw)
1887 !
1888 ! This subroutine calculates the interaction energy of nonbonded side chains
1889 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1890 !
1891       use comm_srutu
1892       use calc_data
1893 !      implicit real*8 (a-h,o-z)
1894 !      include 'DIMENSIONS'
1895 !      include 'COMMON.GEO'
1896 !      include 'COMMON.VAR'
1897 !      include 'COMMON.LOCAL'
1898 !      include 'COMMON.CHAIN'
1899 !      include 'COMMON.DERIV'
1900 !      include 'COMMON.NAMES'
1901 !      include 'COMMON.INTERACT'
1902 !      include 'COMMON.IOUNITS'
1903 !      include 'COMMON.CALC'
1904       use comm_srutu
1905 !el      integer :: icall
1906 !el      common /srutu/ icall
1907       logical :: lprn
1908 !el local variables
1909       integer :: iint,itypi,itypi1,itypj
1910       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1911       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1912
1913 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1914       evdw=0.0D0
1915       lprn=.false.
1916 !     if (icall.eq.0) lprn=.true.
1917 !el      ind=0
1918       do i=iatsc_s,iatsc_e
1919         itypi=iabs(itype(i,1))
1920         if (itypi.eq.ntyp1) cycle
1921         itypi1=iabs(itype(i+1,1))
1922         xi=c(1,nres+i)
1923         yi=c(2,nres+i)
1924         zi=c(3,nres+i)
1925         dxi=dc_norm(1,nres+i)
1926         dyi=dc_norm(2,nres+i)
1927         dzi=dc_norm(3,nres+i)
1928 !        dsci_inv=dsc_inv(itypi)
1929         dsci_inv=vbld_inv(i+nres)
1930 !
1931 ! Calculate SC interaction energy.
1932 !
1933         do iint=1,nint_gr(i)
1934           do j=istart(i,iint),iend(i,iint)
1935 !el            ind=ind+1
1936             itypj=iabs(itype(j,1))
1937             if (itypj.eq.ntyp1) cycle
1938 !            dscj_inv=dsc_inv(itypj)
1939             dscj_inv=vbld_inv(j+nres)
1940             sig0ij=sigma(itypi,itypj)
1941             r0ij=r0(itypi,itypj)
1942             chi1=chi(itypi,itypj)
1943             chi2=chi(itypj,itypi)
1944             chi12=chi1*chi2
1945             chip1=chip(itypi)
1946             chip2=chip(itypj)
1947             chip12=chip1*chip2
1948             alf1=alp(itypi)
1949             alf2=alp(itypj)
1950             alf12=0.5D0*(alf1+alf2)
1951 ! For diagnostics only!!!
1952 !           chi1=0.0D0
1953 !           chi2=0.0D0
1954 !           chi12=0.0D0
1955 !           chip1=0.0D0
1956 !           chip2=0.0D0
1957 !           chip12=0.0D0
1958 !           alf1=0.0D0
1959 !           alf2=0.0D0
1960 !           alf12=0.0D0
1961             xj=c(1,nres+j)-xi
1962             yj=c(2,nres+j)-yi
1963             zj=c(3,nres+j)-zi
1964             dxj=dc_norm(1,nres+j)
1965             dyj=dc_norm(2,nres+j)
1966             dzj=dc_norm(3,nres+j)
1967             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1968             rij=dsqrt(rrij)
1969 ! Calculate angle-dependent terms of energy and contributions to their
1970 ! derivatives.
1971             call sc_angular
1972             sigsq=1.0D0/sigsq
1973             sig=sig0ij*dsqrt(sigsq)
1974             rij_shift=1.0D0/rij-sig+r0ij
1975 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1976             if (rij_shift.le.0.0D0) then
1977               evdw=1.0D20
1978               return
1979             endif
1980             sigder=-sig*sigsq
1981 !---------------------------------------------------------------
1982             rij_shift=1.0D0/rij_shift
1983             fac=rij_shift**expon
1984             e1=fac*fac*aa_aq(itypi,itypj)
1985             e2=fac*bb_aq(itypi,itypj)
1986             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1987             eps2der=evdwij*eps3rt
1988             eps3der=evdwij*eps2rt
1989             fac_augm=rrij**expon
1990             e_augm=augm(itypi,itypj)*fac_augm
1991             evdwij=evdwij*eps2rt*eps3rt
1992             evdw=evdw+evdwij+e_augm
1993             if (lprn) then
1994             sigm=dabs(aa_aq(itypi,itypj)/&
1995             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1996             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1997             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1998               restyp(itypi,1),i,restyp(itypj,1),j,&
1999               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2000               chi1,chi2,chip1,chip2,&
2001               eps1,eps2rt**2,eps3rt**2,&
2002               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2003               evdwij+e_augm
2004             endif
2005 ! Calculate gradient components.
2006             e1=e1*eps1*eps2rt**2*eps3rt**2
2007             fac=-expon*(e1+evdwij)*rij_shift
2008             sigder=fac*sigder
2009             fac=rij*fac-2*expon*rrij*e_augm
2010 ! Calculate the radial part of the gradient
2011             gg(1)=xj*fac
2012             gg(2)=yj*fac
2013             gg(3)=zj*fac
2014 ! Calculate angular part of the gradient.
2015             call sc_grad
2016           enddo      ! j
2017         enddo        ! iint
2018       enddo          ! i
2019       end subroutine egbv
2020 !-----------------------------------------------------------------------------
2021 !el      subroutine sc_angular in module geometry
2022 !-----------------------------------------------------------------------------
2023       subroutine e_softsphere(evdw)
2024 !
2025 ! This subroutine calculates the interaction energy of nonbonded side chains
2026 ! assuming the LJ potential of interaction.
2027 !
2028 !      implicit real*8 (a-h,o-z)
2029 !      include 'DIMENSIONS'
2030       real(kind=8),parameter :: accur=1.0d-10
2031 !      include 'COMMON.GEO'
2032 !      include 'COMMON.VAR'
2033 !      include 'COMMON.LOCAL'
2034 !      include 'COMMON.CHAIN'
2035 !      include 'COMMON.DERIV'
2036 !      include 'COMMON.INTERACT'
2037 !      include 'COMMON.TORSION'
2038 !      include 'COMMON.SBRIDGE'
2039 !      include 'COMMON.NAMES'
2040 !      include 'COMMON.IOUNITS'
2041 !      include 'COMMON.CONTACTS'
2042       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2043 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2044 !el local variables
2045       integer :: i,iint,j,itypi,itypi1,itypj,k
2046       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2047       real(kind=8) :: fac
2048
2049       evdw=0.0D0
2050       do i=iatsc_s,iatsc_e
2051         itypi=iabs(itype(i,1))
2052         if (itypi.eq.ntyp1) cycle
2053         itypi1=iabs(itype(i+1,1))
2054         xi=c(1,nres+i)
2055         yi=c(2,nres+i)
2056         zi=c(3,nres+i)
2057 !
2058 ! Calculate SC interaction energy.
2059 !
2060         do iint=1,nint_gr(i)
2061 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2062 !d   &                  'iend=',iend(i,iint)
2063           do j=istart(i,iint),iend(i,iint)
2064             itypj=iabs(itype(j,1))
2065             if (itypj.eq.ntyp1) cycle
2066             xj=c(1,nres+j)-xi
2067             yj=c(2,nres+j)-yi
2068             zj=c(3,nres+j)-zi
2069             rij=xj*xj+yj*yj+zj*zj
2070 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2071             r0ij=r0(itypi,itypj)
2072             r0ijsq=r0ij*r0ij
2073 !            print *,i,j,r0ij,dsqrt(rij)
2074             if (rij.lt.r0ijsq) then
2075               evdwij=0.25d0*(rij-r0ijsq)**2
2076               fac=rij-r0ijsq
2077             else
2078               evdwij=0.0d0
2079               fac=0.0d0
2080             endif
2081             evdw=evdw+evdwij
2082 !
2083 ! Calculate the components of the gradient in DC and X
2084 !
2085             gg(1)=xj*fac
2086             gg(2)=yj*fac
2087             gg(3)=zj*fac
2088             do k=1,3
2089               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2090               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2091               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2092               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2093             enddo
2094 !grad            do k=i,j-1
2095 !grad              do l=1,3
2096 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2097 !grad              enddo
2098 !grad            enddo
2099           enddo ! j
2100         enddo ! iint
2101       enddo ! i
2102       return
2103       end subroutine e_softsphere
2104 !-----------------------------------------------------------------------------
2105       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2106 !
2107 ! Soft-sphere potential of p-p interaction
2108 !
2109 !      implicit real*8 (a-h,o-z)
2110 !      include 'DIMENSIONS'
2111 !      include 'COMMON.CONTROL'
2112 !      include 'COMMON.IOUNITS'
2113 !      include 'COMMON.GEO'
2114 !      include 'COMMON.VAR'
2115 !      include 'COMMON.LOCAL'
2116 !      include 'COMMON.CHAIN'
2117 !      include 'COMMON.DERIV'
2118 !      include 'COMMON.INTERACT'
2119 !      include 'COMMON.CONTACTS'
2120 !      include 'COMMON.TORSION'
2121 !      include 'COMMON.VECTORS'
2122 !      include 'COMMON.FFIELD'
2123       real(kind=8),dimension(3) :: ggg
2124 !d      write(iout,*) 'In EELEC_soft_sphere'
2125 !el local variables
2126       integer :: i,j,k,num_conti,iteli,itelj
2127       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2128       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2129       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2130
2131       ees=0.0D0
2132       evdw1=0.0D0
2133       eel_loc=0.0d0
2134       eello_turn3=0.0d0
2135       eello_turn4=0.0d0
2136 !el      ind=0
2137       do i=iatel_s,iatel_e
2138         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2139         dxi=dc(1,i)
2140         dyi=dc(2,i)
2141         dzi=dc(3,i)
2142         xmedi=c(1,i)+0.5d0*dxi
2143         ymedi=c(2,i)+0.5d0*dyi
2144         zmedi=c(3,i)+0.5d0*dzi
2145         num_conti=0
2146 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2147         do j=ielstart(i),ielend(i)
2148           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2149 !el          ind=ind+1
2150           iteli=itel(i)
2151           itelj=itel(j)
2152           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2153           r0ij=rpp(iteli,itelj)
2154           r0ijsq=r0ij*r0ij
2155           dxj=dc(1,j)
2156           dyj=dc(2,j)
2157           dzj=dc(3,j)
2158           xj=c(1,j)+0.5D0*dxj-xmedi
2159           yj=c(2,j)+0.5D0*dyj-ymedi
2160           zj=c(3,j)+0.5D0*dzj-zmedi
2161           rij=xj*xj+yj*yj+zj*zj
2162           if (rij.lt.r0ijsq) then
2163             evdw1ij=0.25d0*(rij-r0ijsq)**2
2164             fac=rij-r0ijsq
2165           else
2166             evdw1ij=0.0d0
2167             fac=0.0d0
2168           endif
2169           evdw1=evdw1+evdw1ij
2170 !
2171 ! Calculate contributions to the Cartesian gradient.
2172 !
2173           ggg(1)=fac*xj
2174           ggg(2)=fac*yj
2175           ggg(3)=fac*zj
2176           do k=1,3
2177             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2178             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2179           enddo
2180 !
2181 ! Loop over residues i+1 thru j-1.
2182 !
2183 !grad          do k=i+1,j-1
2184 !grad            do l=1,3
2185 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2186 !grad            enddo
2187 !grad          enddo
2188         enddo ! j
2189       enddo   ! i
2190 !grad      do i=nnt,nct-1
2191 !grad        do k=1,3
2192 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2193 !grad        enddo
2194 !grad        do j=i+1,nct-1
2195 !grad          do k=1,3
2196 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2197 !grad          enddo
2198 !grad        enddo
2199 !grad      enddo
2200       return
2201       end subroutine eelec_soft_sphere
2202 !-----------------------------------------------------------------------------
2203       subroutine vec_and_deriv
2204 !      implicit real*8 (a-h,o-z)
2205 !      include 'DIMENSIONS'
2206 #ifdef MPI
2207       include 'mpif.h'
2208 #endif
2209 !      include 'COMMON.IOUNITS'
2210 !      include 'COMMON.GEO'
2211 !      include 'COMMON.VAR'
2212 !      include 'COMMON.LOCAL'
2213 !      include 'COMMON.CHAIN'
2214 !      include 'COMMON.VECTORS'
2215 !      include 'COMMON.SETUP'
2216 !      include 'COMMON.TIME1'
2217       real(kind=8),dimension(3,3,2) :: uyder,uzder
2218       real(kind=8),dimension(2) :: vbld_inv_temp
2219 ! Compute the local reference systems. For reference system (i), the
2220 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2221 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2222 !el local variables
2223       integer :: i,j,k,l
2224       real(kind=8) :: facy,fac,costh
2225
2226 #ifdef PARVEC
2227       do i=ivec_start,ivec_end
2228 #else
2229       do i=1,nres-1
2230 #endif
2231           if (i.eq.nres-1) then
2232 ! Case of the last full residue
2233 ! Compute the Z-axis
2234             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2235             costh=dcos(pi-theta(nres))
2236             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2237             do k=1,3
2238               uz(k,i)=fac*uz(k,i)
2239             enddo
2240 ! Compute the derivatives of uz
2241             uzder(1,1,1)= 0.0d0
2242             uzder(2,1,1)=-dc_norm(3,i-1)
2243             uzder(3,1,1)= dc_norm(2,i-1)
2244             uzder(1,2,1)= dc_norm(3,i-1)
2245             uzder(2,2,1)= 0.0d0
2246             uzder(3,2,1)=-dc_norm(1,i-1)
2247             uzder(1,3,1)=-dc_norm(2,i-1)
2248             uzder(2,3,1)= dc_norm(1,i-1)
2249             uzder(3,3,1)= 0.0d0
2250             uzder(1,1,2)= 0.0d0
2251             uzder(2,1,2)= dc_norm(3,i)
2252             uzder(3,1,2)=-dc_norm(2,i)
2253             uzder(1,2,2)=-dc_norm(3,i)
2254             uzder(2,2,2)= 0.0d0
2255             uzder(3,2,2)= dc_norm(1,i)
2256             uzder(1,3,2)= dc_norm(2,i)
2257             uzder(2,3,2)=-dc_norm(1,i)
2258             uzder(3,3,2)= 0.0d0
2259 ! Compute the Y-axis
2260             facy=fac
2261             do k=1,3
2262               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2263             enddo
2264 ! Compute the derivatives of uy
2265             do j=1,3
2266               do k=1,3
2267                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2268                               -dc_norm(k,i)*dc_norm(j,i-1)
2269                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2270               enddo
2271               uyder(j,j,1)=uyder(j,j,1)-costh
2272               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2273             enddo
2274             do j=1,2
2275               do k=1,3
2276                 do l=1,3
2277                   uygrad(l,k,j,i)=uyder(l,k,j)
2278                   uzgrad(l,k,j,i)=uzder(l,k,j)
2279                 enddo
2280               enddo
2281             enddo
2282             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2283             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2284             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2285             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2286           else
2287 ! Other residues
2288 ! Compute the Z-axis
2289             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2290             costh=dcos(pi-theta(i+2))
2291             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2292             do k=1,3
2293               uz(k,i)=fac*uz(k,i)
2294             enddo
2295 ! Compute the derivatives of uz
2296             uzder(1,1,1)= 0.0d0
2297             uzder(2,1,1)=-dc_norm(3,i+1)
2298             uzder(3,1,1)= dc_norm(2,i+1)
2299             uzder(1,2,1)= dc_norm(3,i+1)
2300             uzder(2,2,1)= 0.0d0
2301             uzder(3,2,1)=-dc_norm(1,i+1)
2302             uzder(1,3,1)=-dc_norm(2,i+1)
2303             uzder(2,3,1)= dc_norm(1,i+1)
2304             uzder(3,3,1)= 0.0d0
2305             uzder(1,1,2)= 0.0d0
2306             uzder(2,1,2)= dc_norm(3,i)
2307             uzder(3,1,2)=-dc_norm(2,i)
2308             uzder(1,2,2)=-dc_norm(3,i)
2309             uzder(2,2,2)= 0.0d0
2310             uzder(3,2,2)= dc_norm(1,i)
2311             uzder(1,3,2)= dc_norm(2,i)
2312             uzder(2,3,2)=-dc_norm(1,i)
2313             uzder(3,3,2)= 0.0d0
2314 ! Compute the Y-axis
2315             facy=fac
2316             do k=1,3
2317               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2318             enddo
2319 ! Compute the derivatives of uy
2320             do j=1,3
2321               do k=1,3
2322                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2323                               -dc_norm(k,i)*dc_norm(j,i+1)
2324                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2325               enddo
2326               uyder(j,j,1)=uyder(j,j,1)-costh
2327               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2328             enddo
2329             do j=1,2
2330               do k=1,3
2331                 do l=1,3
2332                   uygrad(l,k,j,i)=uyder(l,k,j)
2333                   uzgrad(l,k,j,i)=uzder(l,k,j)
2334                 enddo
2335               enddo
2336             enddo
2337             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2338             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2339             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2340             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2341           endif
2342       enddo
2343       do i=1,nres-1
2344         vbld_inv_temp(1)=vbld_inv(i+1)
2345         if (i.lt.nres-1) then
2346           vbld_inv_temp(2)=vbld_inv(i+2)
2347           else
2348           vbld_inv_temp(2)=vbld_inv(i)
2349           endif
2350         do j=1,2
2351           do k=1,3
2352             do l=1,3
2353               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2354               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2355             enddo
2356           enddo
2357         enddo
2358       enddo
2359 #if defined(PARVEC) && defined(MPI)
2360       if (nfgtasks1.gt.1) then
2361         time00=MPI_Wtime()
2362 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2363 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2364 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2365         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2366          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2367          FG_COMM1,IERR)
2368         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2369          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2370          FG_COMM1,IERR)
2371         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2372          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2373          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2374         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2375          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2376          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2377         time_gather=time_gather+MPI_Wtime()-time00
2378       endif
2379 !      if (fg_rank.eq.0) then
2380 !        write (iout,*) "Arrays UY and UZ"
2381 !        do i=1,nres-1
2382 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2383 !     &     (uz(k,i),k=1,3)
2384 !        enddo
2385 !      endif
2386 #endif
2387       return
2388       end subroutine vec_and_deriv
2389 !-----------------------------------------------------------------------------
2390       subroutine check_vecgrad
2391 !      implicit real*8 (a-h,o-z)
2392 !      include 'DIMENSIONS'
2393 !      include 'COMMON.IOUNITS'
2394 !      include 'COMMON.GEO'
2395 !      include 'COMMON.VAR'
2396 !      include 'COMMON.LOCAL'
2397 !      include 'COMMON.CHAIN'
2398 !      include 'COMMON.VECTORS'
2399       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2400       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2401       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2402       real(kind=8),dimension(3) :: erij
2403       real(kind=8) :: delta=1.0d-7
2404 !el local variables
2405       integer :: i,j,k,l
2406
2407       call vec_and_deriv
2408 !d      do i=1,nres
2409 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2410 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2411 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2412 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2413 !d     &     (dc_norm(if90,i),if90=1,3)
2414 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2415 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2416 !d          write(iout,'(a)')
2417 !d      enddo
2418       do i=1,nres
2419         do j=1,2
2420           do k=1,3
2421             do l=1,3
2422               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2423               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2424             enddo
2425           enddo
2426         enddo
2427       enddo
2428       call vec_and_deriv
2429       do i=1,nres
2430         do j=1,3
2431           uyt(j,i)=uy(j,i)
2432           uzt(j,i)=uz(j,i)
2433         enddo
2434       enddo
2435       do i=1,nres
2436 !d        write (iout,*) 'i=',i
2437         do k=1,3
2438           erij(k)=dc_norm(k,i)
2439         enddo
2440         do j=1,3
2441           do k=1,3
2442             dc_norm(k,i)=erij(k)
2443           enddo
2444           dc_norm(j,i)=dc_norm(j,i)+delta
2445 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2446 !          do k=1,3
2447 !            dc_norm(k,i)=dc_norm(k,i)/fac
2448 !          enddo
2449 !          write (iout,*) (dc_norm(k,i),k=1,3)
2450 !          write (iout,*) (erij(k),k=1,3)
2451           call vec_and_deriv
2452           do k=1,3
2453             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2454             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2455             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2456             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2457           enddo
2458 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2459 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2460 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2461         enddo
2462         do k=1,3
2463           dc_norm(k,i)=erij(k)
2464         enddo
2465 !d        do k=1,3
2466 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2467 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2468 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2469 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2470 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2471 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2472 !d          write (iout,'(a)')
2473 !d        enddo
2474       enddo
2475       return
2476       end subroutine check_vecgrad
2477 !-----------------------------------------------------------------------------
2478       subroutine set_matrices
2479 !      implicit real*8 (a-h,o-z)
2480 !      include 'DIMENSIONS'
2481 #ifdef MPI
2482       include "mpif.h"
2483 !      include "COMMON.SETUP"
2484       integer :: IERR
2485       integer :: status(MPI_STATUS_SIZE)
2486 #endif
2487 !      include 'COMMON.IOUNITS'
2488 !      include 'COMMON.GEO'
2489 !      include 'COMMON.VAR'
2490 !      include 'COMMON.LOCAL'
2491 !      include 'COMMON.CHAIN'
2492 !      include 'COMMON.DERIV'
2493 !      include 'COMMON.INTERACT'
2494 !      include 'COMMON.CONTACTS'
2495 !      include 'COMMON.TORSION'
2496 !      include 'COMMON.VECTORS'
2497 !      include 'COMMON.FFIELD'
2498       real(kind=8) :: auxvec(2),auxmat(2,2)
2499       integer :: i,iti1,iti,k,l
2500       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2501 !       print *,"in set matrices"
2502 !
2503 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2504 ! to calculate the el-loc multibody terms of various order.
2505 !
2506 !AL el      mu=0.0d0
2507 #ifdef PARMAT
2508       do i=ivec_start+2,ivec_end+2
2509 #else
2510       do i=3,nres+1
2511 #endif
2512 !      print *,i,"i"
2513         if (i .lt. nres+1) then
2514           sin1=dsin(phi(i))
2515           cos1=dcos(phi(i))
2516           sintab(i-2)=sin1
2517           costab(i-2)=cos1
2518           obrot(1,i-2)=cos1
2519           obrot(2,i-2)=sin1
2520           sin2=dsin(2*phi(i))
2521           cos2=dcos(2*phi(i))
2522           sintab2(i-2)=sin2
2523           costab2(i-2)=cos2
2524           obrot2(1,i-2)=cos2
2525           obrot2(2,i-2)=sin2
2526           Ug(1,1,i-2)=-cos1
2527           Ug(1,2,i-2)=-sin1
2528           Ug(2,1,i-2)=-sin1
2529           Ug(2,2,i-2)= cos1
2530           Ug2(1,1,i-2)=-cos2
2531           Ug2(1,2,i-2)=-sin2
2532           Ug2(2,1,i-2)=-sin2
2533           Ug2(2,2,i-2)= cos2
2534         else
2535           costab(i-2)=1.0d0
2536           sintab(i-2)=0.0d0
2537           obrot(1,i-2)=1.0d0
2538           obrot(2,i-2)=0.0d0
2539           obrot2(1,i-2)=0.0d0
2540           obrot2(2,i-2)=0.0d0
2541           Ug(1,1,i-2)=1.0d0
2542           Ug(1,2,i-2)=0.0d0
2543           Ug(2,1,i-2)=0.0d0
2544           Ug(2,2,i-2)=1.0d0
2545           Ug2(1,1,i-2)=0.0d0
2546           Ug2(1,2,i-2)=0.0d0
2547           Ug2(2,1,i-2)=0.0d0
2548           Ug2(2,2,i-2)=0.0d0
2549         endif
2550         if (i .gt. 3 .and. i .lt. nres+1) then
2551           obrot_der(1,i-2)=-sin1
2552           obrot_der(2,i-2)= cos1
2553           Ugder(1,1,i-2)= sin1
2554           Ugder(1,2,i-2)=-cos1
2555           Ugder(2,1,i-2)=-cos1
2556           Ugder(2,2,i-2)=-sin1
2557           dwacos2=cos2+cos2
2558           dwasin2=sin2+sin2
2559           obrot2_der(1,i-2)=-dwasin2
2560           obrot2_der(2,i-2)= dwacos2
2561           Ug2der(1,1,i-2)= dwasin2
2562           Ug2der(1,2,i-2)=-dwacos2
2563           Ug2der(2,1,i-2)=-dwacos2
2564           Ug2der(2,2,i-2)=-dwasin2
2565         else
2566           obrot_der(1,i-2)=0.0d0
2567           obrot_der(2,i-2)=0.0d0
2568           Ugder(1,1,i-2)=0.0d0
2569           Ugder(1,2,i-2)=0.0d0
2570           Ugder(2,1,i-2)=0.0d0
2571           Ugder(2,2,i-2)=0.0d0
2572           obrot2_der(1,i-2)=0.0d0
2573           obrot2_der(2,i-2)=0.0d0
2574           Ug2der(1,1,i-2)=0.0d0
2575           Ug2der(1,2,i-2)=0.0d0
2576           Ug2der(2,1,i-2)=0.0d0
2577           Ug2der(2,2,i-2)=0.0d0
2578         endif
2579 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2580         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2581            if (itype(i-2,1).eq.0) then
2582           iti=ntortyp+1
2583            else
2584           iti = itortyp(itype(i-2,1))
2585            endif
2586         else
2587           iti=ntortyp+1
2588         endif
2589 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2590         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2591            if (itype(i-1,1).eq.0) then
2592           iti1=ntortyp+1
2593            else
2594           iti1 = itortyp(itype(i-1,1))
2595            endif
2596         else
2597           iti1=ntortyp+1
2598         endif
2599 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2600 !d        write (iout,*) '*******i',i,' iti1',iti
2601 !d        write (iout,*) 'b1',b1(:,iti)
2602 !d        write (iout,*) 'b2',b2(:,iti)
2603 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2604 !        if (i .gt. iatel_s+2) then
2605         if (i .gt. nnt+2) then
2606           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2607           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2608           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2609           then
2610           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2611           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2612           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2613           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2614           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2615           endif
2616         else
2617           do k=1,2
2618             Ub2(k,i-2)=0.0d0
2619             Ctobr(k,i-2)=0.0d0
2620             Dtobr2(k,i-2)=0.0d0
2621             do l=1,2
2622               EUg(l,k,i-2)=0.0d0
2623               CUg(l,k,i-2)=0.0d0
2624               DUg(l,k,i-2)=0.0d0
2625               DtUg2(l,k,i-2)=0.0d0
2626             enddo
2627           enddo
2628         endif
2629         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2630         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2631         do k=1,2
2632           muder(k,i-2)=Ub2der(k,i-2)
2633         enddo
2634 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2635         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2636           if (itype(i-1,1).eq.0) then
2637            iti1=ntortyp+1
2638           elseif (itype(i-1,1).le.ntyp) then
2639             iti1 = itortyp(itype(i-1,1))
2640           else
2641             iti1=ntortyp+1
2642           endif
2643         else
2644           iti1=ntortyp+1
2645         endif
2646         do k=1,2
2647           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2648         enddo
2649 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2650 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2651 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2652 !d        write (iout,*) 'mu1',mu1(:,i-2)
2653 !d        write (iout,*) 'mu2',mu2(:,i-2)
2654         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2655         then
2656         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2657         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2658         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2659         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2660         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2661 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2662         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2663         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2664         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2665         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2666         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2667         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2668         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2669         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2670         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2671         endif
2672       enddo
2673 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2674 ! The order of matrices is from left to right.
2675       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2676       then
2677 !      do i=max0(ivec_start,2),ivec_end
2678       do i=2,nres-1
2679         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2680         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2681         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2682         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2683         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2684         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2685         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2686         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2687       enddo
2688       endif
2689 #if defined(MPI) && defined(PARMAT)
2690 #ifdef DEBUG
2691 !      if (fg_rank.eq.0) then
2692         write (iout,*) "Arrays UG and UGDER before GATHER"
2693         do i=1,nres-1
2694           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2695            ((ug(l,k,i),l=1,2),k=1,2),&
2696            ((ugder(l,k,i),l=1,2),k=1,2)
2697         enddo
2698         write (iout,*) "Arrays UG2 and UG2DER"
2699         do i=1,nres-1
2700           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2701            ((ug2(l,k,i),l=1,2),k=1,2),&
2702            ((ug2der(l,k,i),l=1,2),k=1,2)
2703         enddo
2704         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2705         do i=1,nres-1
2706           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2707            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2708            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2709         enddo
2710         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2711         do i=1,nres-1
2712           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2713            costab(i),sintab(i),costab2(i),sintab2(i)
2714         enddo
2715         write (iout,*) "Array MUDER"
2716         do i=1,nres-1
2717           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2718         enddo
2719 !      endif
2720 #endif
2721       if (nfgtasks.gt.1) then
2722         time00=MPI_Wtime()
2723 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2724 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2725 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2726 #ifdef MATGATHER
2727         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2728          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2729          FG_COMM1,IERR)
2730         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2731          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2732          FG_COMM1,IERR)
2733         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2734          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2735          FG_COMM1,IERR)
2736         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2737          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2738          FG_COMM1,IERR)
2739         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2740          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2741          FG_COMM1,IERR)
2742         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2743          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2744          FG_COMM1,IERR)
2745         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2746          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2747          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2748         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2749          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2750          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2751         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2752          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2753          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2754         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2755          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2756          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2757         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2758         then
2759         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2760          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2761          FG_COMM1,IERR)
2762         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2763          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2764          FG_COMM1,IERR)
2765         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2766          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2767          FG_COMM1,IERR)
2768        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2769          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2770          FG_COMM1,IERR)
2771         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2772          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2773          FG_COMM1,IERR)
2774         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2775          ivec_count(fg_rank1),&
2776          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2777          FG_COMM1,IERR)
2778         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2779          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2780          FG_COMM1,IERR)
2781         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2782          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2783          FG_COMM1,IERR)
2784         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2785          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2786          FG_COMM1,IERR)
2787         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2788          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2789          FG_COMM1,IERR)
2790         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2791          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2792          FG_COMM1,IERR)
2793         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2794          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2795          FG_COMM1,IERR)
2796         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2797          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2798          FG_COMM1,IERR)
2799         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2800          ivec_count(fg_rank1),&
2801          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2802          FG_COMM1,IERR)
2803         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2804          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2805          FG_COMM1,IERR)
2806        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2807          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2808          FG_COMM1,IERR)
2809         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2810          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2811          FG_COMM1,IERR)
2812        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2813          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2814          FG_COMM1,IERR)
2815         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2816          ivec_count(fg_rank1),&
2817          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2818          FG_COMM1,IERR)
2819         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2820          ivec_count(fg_rank1),&
2821          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2822          FG_COMM1,IERR)
2823         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2824          ivec_count(fg_rank1),&
2825          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2826          MPI_MAT2,FG_COMM1,IERR)
2827         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2828          ivec_count(fg_rank1),&
2829          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2830          MPI_MAT2,FG_COMM1,IERR)
2831         endif
2832 #else
2833 ! Passes matrix info through the ring
2834       isend=fg_rank1
2835       irecv=fg_rank1-1
2836       if (irecv.lt.0) irecv=nfgtasks1-1
2837       iprev=irecv
2838       inext=fg_rank1+1
2839       if (inext.ge.nfgtasks1) inext=0
2840       do i=1,nfgtasks1-1
2841 !        write (iout,*) "isend",isend," irecv",irecv
2842 !        call flush(iout)
2843         lensend=lentyp(isend)
2844         lenrecv=lentyp(irecv)
2845 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2846 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2847 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2848 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2849 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2850 !        write (iout,*) "Gather ROTAT1"
2851 !        call flush(iout)
2852 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2853 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2854 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2855 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2856 !        write (iout,*) "Gather ROTAT2"
2857 !        call flush(iout)
2858         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2859          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2860          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2861          iprev,4400+irecv,FG_COMM,status,IERR)
2862 !        write (iout,*) "Gather ROTAT_OLD"
2863 !        call flush(iout)
2864         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2865          MPI_PRECOMP11(lensend),inext,5500+isend,&
2866          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2867          iprev,5500+irecv,FG_COMM,status,IERR)
2868 !        write (iout,*) "Gather PRECOMP11"
2869 !        call flush(iout)
2870         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2871          MPI_PRECOMP12(lensend),inext,6600+isend,&
2872          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2873          iprev,6600+irecv,FG_COMM,status,IERR)
2874 !        write (iout,*) "Gather PRECOMP12"
2875 !        call flush(iout)
2876         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2877         then
2878         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2879          MPI_ROTAT2(lensend),inext,7700+isend,&
2880          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2881          iprev,7700+irecv,FG_COMM,status,IERR)
2882 !        write (iout,*) "Gather PRECOMP21"
2883 !        call flush(iout)
2884         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2885          MPI_PRECOMP22(lensend),inext,8800+isend,&
2886          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2887          iprev,8800+irecv,FG_COMM,status,IERR)
2888 !        write (iout,*) "Gather PRECOMP22"
2889 !        call flush(iout)
2890         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2891          MPI_PRECOMP23(lensend),inext,9900+isend,&
2892          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2893          MPI_PRECOMP23(lenrecv),&
2894          iprev,9900+irecv,FG_COMM,status,IERR)
2895 !        write (iout,*) "Gather PRECOMP23"
2896 !        call flush(iout)
2897         endif
2898         isend=irecv
2899         irecv=irecv-1
2900         if (irecv.lt.0) irecv=nfgtasks1-1
2901       enddo
2902 #endif
2903         time_gather=time_gather+MPI_Wtime()-time00
2904       endif
2905 #ifdef DEBUG
2906 !      if (fg_rank.eq.0) then
2907         write (iout,*) "Arrays UG and UGDER"
2908         do i=1,nres-1
2909           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2910            ((ug(l,k,i),l=1,2),k=1,2),&
2911            ((ugder(l,k,i),l=1,2),k=1,2)
2912         enddo
2913         write (iout,*) "Arrays UG2 and UG2DER"
2914         do i=1,nres-1
2915           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2916            ((ug2(l,k,i),l=1,2),k=1,2),&
2917            ((ug2der(l,k,i),l=1,2),k=1,2)
2918         enddo
2919         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2920         do i=1,nres-1
2921           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2922            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2923            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2924         enddo
2925         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2926         do i=1,nres-1
2927           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2928            costab(i),sintab(i),costab2(i),sintab2(i)
2929         enddo
2930         write (iout,*) "Array MUDER"
2931         do i=1,nres-1
2932           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2933         enddo
2934 !      endif
2935 #endif
2936 #endif
2937 !d      do i=1,nres
2938 !d        iti = itortyp(itype(i,1))
2939 !d        write (iout,*) i
2940 !d        do j=1,2
2941 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2942 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2943 !d        enddo
2944 !d      enddo
2945       return
2946       end subroutine set_matrices
2947 !-----------------------------------------------------------------------------
2948       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2949 !
2950 ! This subroutine calculates the average interaction energy and its gradient
2951 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2952 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2953 ! The potential depends both on the distance of peptide-group centers and on
2954 ! the orientation of the CA-CA virtual bonds.
2955 !
2956       use comm_locel
2957 !      implicit real*8 (a-h,o-z)
2958 #ifdef MPI
2959       include 'mpif.h'
2960 #endif
2961 !      include 'DIMENSIONS'
2962 !      include 'COMMON.CONTROL'
2963 !      include 'COMMON.SETUP'
2964 !      include 'COMMON.IOUNITS'
2965 !      include 'COMMON.GEO'
2966 !      include 'COMMON.VAR'
2967 !      include 'COMMON.LOCAL'
2968 !      include 'COMMON.CHAIN'
2969 !      include 'COMMON.DERIV'
2970 !      include 'COMMON.INTERACT'
2971 !      include 'COMMON.CONTACTS'
2972 !      include 'COMMON.TORSION'
2973 !      include 'COMMON.VECTORS'
2974 !      include 'COMMON.FFIELD'
2975 !      include 'COMMON.TIME1'
2976       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2977       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2978       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2979 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2980       real(kind=8),dimension(4) :: muij
2981 !el      integer :: num_conti,j1,j2
2982 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2983 !el        dz_normi,xmedi,ymedi,zmedi
2984
2985 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2986 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2987 !el          num_conti,j1,j2
2988
2989 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2990 #ifdef MOMENT
2991       real(kind=8) :: scal_el=1.0d0
2992 #else
2993       real(kind=8) :: scal_el=0.5d0
2994 #endif
2995 ! 12/13/98
2996 ! 13-go grudnia roku pamietnego...
2997       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2998                                              0.0d0,1.0d0,0.0d0,&
2999                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3000 !el local variables
3001       integer :: i,k,j
3002       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3003       real(kind=8) :: fac,t_eelecij,fracinbuf
3004
3005
3006 !d      write(iout,*) 'In EELEC'
3007 !        print *,"IN EELEC"
3008 !d      do i=1,nloctyp
3009 !d        write(iout,*) 'Type',i
3010 !d        write(iout,*) 'B1',B1(:,i)
3011 !d        write(iout,*) 'B2',B2(:,i)
3012 !d        write(iout,*) 'CC',CC(:,:,i)
3013 !d        write(iout,*) 'DD',DD(:,:,i)
3014 !d        write(iout,*) 'EE',EE(:,:,i)
3015 !d      enddo
3016 !d      call check_vecgrad
3017 !d      stop
3018 !      ees=0.0d0  !AS
3019 !      evdw1=0.0d0
3020 !      eel_loc=0.0d0
3021 !      eello_turn3=0.0d0
3022 !      eello_turn4=0.0d0
3023       t_eelecij=0.0d0
3024       ees=0.0D0
3025       evdw1=0.0D0
3026       eel_loc=0.0d0
3027       eello_turn3=0.0d0
3028       eello_turn4=0.0d0
3029 !
3030
3031       if (icheckgrad.eq.1) then
3032 !el
3033 !        do i=0,2*nres+2
3034 !          dc_norm(1,i)=0.0d0
3035 !          dc_norm(2,i)=0.0d0
3036 !          dc_norm(3,i)=0.0d0
3037 !        enddo
3038         do i=1,nres-1
3039           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3040           do k=1,3
3041             dc_norm(k,i)=dc(k,i)*fac
3042           enddo
3043 !          write (iout,*) 'i',i,' fac',fac
3044         enddo
3045       endif
3046 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3047 !        wturn6
3048       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3049           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3050           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3051 !        call vec_and_deriv
3052 #ifdef TIMING
3053         time01=MPI_Wtime()
3054 #endif
3055 !        print *, "before set matrices"
3056         call set_matrices
3057 !        print *, "after set matrices"
3058
3059 #ifdef TIMING
3060         time_mat=time_mat+MPI_Wtime()-time01
3061 #endif
3062       endif
3063 !       print *, "after set matrices"
3064 !d      do i=1,nres-1
3065 !d        write (iout,*) 'i=',i
3066 !d        do k=1,3
3067 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3068 !d        enddo
3069 !d        do k=1,3
3070 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3071 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3072 !d        enddo
3073 !d      enddo
3074       t_eelecij=0.0d0
3075       ees=0.0D0
3076       evdw1=0.0D0
3077       eel_loc=0.0d0
3078       eello_turn3=0.0d0
3079       eello_turn4=0.0d0
3080 !el      ind=0
3081       do i=1,nres
3082         num_cont_hb(i)=0
3083       enddo
3084 !d      print '(a)','Enter EELEC'
3085 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3086 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3087 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3088       do i=1,nres
3089         gel_loc_loc(i)=0.0d0
3090         gcorr_loc(i)=0.0d0
3091       enddo
3092 !
3093 !
3094 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3095 !
3096 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3097 !
3098
3099
3100 !        print *,"before iturn3 loop"
3101       do i=iturn3_start,iturn3_end
3102         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3103         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3104         dxi=dc(1,i)
3105         dyi=dc(2,i)
3106         dzi=dc(3,i)
3107         dx_normi=dc_norm(1,i)
3108         dy_normi=dc_norm(2,i)
3109         dz_normi=dc_norm(3,i)
3110         xmedi=c(1,i)+0.5d0*dxi
3111         ymedi=c(2,i)+0.5d0*dyi
3112         zmedi=c(3,i)+0.5d0*dzi
3113           xmedi=dmod(xmedi,boxxsize)
3114           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3115           ymedi=dmod(ymedi,boxysize)
3116           if (ymedi.lt.0) ymedi=ymedi+boxysize
3117           zmedi=dmod(zmedi,boxzsize)
3118           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3119         num_conti=0
3120        if ((zmedi.gt.bordlipbot) &
3121         .and.(zmedi.lt.bordliptop)) then
3122 !C the energy transfer exist
3123         if (zmedi.lt.buflipbot) then
3124 !C what fraction I am in
3125          fracinbuf=1.0d0- &
3126                ((zmedi-bordlipbot)/lipbufthick)
3127 !C lipbufthick is thickenes of lipid buffore
3128          sslipi=sscalelip(fracinbuf)
3129          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3130         elseif (zmedi.gt.bufliptop) then
3131          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3132          sslipi=sscalelip(fracinbuf)
3133          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3134         else
3135          sslipi=1.0d0
3136          ssgradlipi=0.0
3137         endif
3138        else
3139          sslipi=0.0d0
3140          ssgradlipi=0.0
3141        endif
3142 !       print *,i,sslipi,ssgradlipi
3143        call eelecij(i,i+2,ees,evdw1,eel_loc)
3144         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3145         num_cont_hb(i)=num_conti
3146       enddo
3147       do i=iturn4_start,iturn4_end
3148         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3149           .or. itype(i+3,1).eq.ntyp1 &
3150           .or. itype(i+4,1).eq.ntyp1) cycle
3151         dxi=dc(1,i)
3152         dyi=dc(2,i)
3153         dzi=dc(3,i)
3154         dx_normi=dc_norm(1,i)
3155         dy_normi=dc_norm(2,i)
3156         dz_normi=dc_norm(3,i)
3157         xmedi=c(1,i)+0.5d0*dxi
3158         ymedi=c(2,i)+0.5d0*dyi
3159         zmedi=c(3,i)+0.5d0*dzi
3160           xmedi=dmod(xmedi,boxxsize)
3161           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3162           ymedi=dmod(ymedi,boxysize)
3163           if (ymedi.lt.0) ymedi=ymedi+boxysize
3164           zmedi=dmod(zmedi,boxzsize)
3165           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3166        if ((zmedi.gt.bordlipbot)  &
3167        .and.(zmedi.lt.bordliptop)) then
3168 !C the energy transfer exist
3169         if (zmedi.lt.buflipbot) then
3170 !C what fraction I am in
3171          fracinbuf=1.0d0- &
3172              ((zmedi-bordlipbot)/lipbufthick)
3173 !C lipbufthick is thickenes of lipid buffore
3174          sslipi=sscalelip(fracinbuf)
3175          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3176         elseif (zmedi.gt.bufliptop) then
3177          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3178          sslipi=sscalelip(fracinbuf)
3179          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3180         else
3181          sslipi=1.0d0
3182          ssgradlipi=0.0
3183         endif
3184        else
3185          sslipi=0.0d0
3186          ssgradlipi=0.0
3187        endif
3188
3189         num_conti=num_cont_hb(i)
3190         call eelecij(i,i+3,ees,evdw1,eel_loc)
3191         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3192          call eturn4(i,eello_turn4)
3193         num_cont_hb(i)=num_conti
3194       enddo   ! i
3195 !
3196 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3197 !
3198 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3199       do i=iatel_s,iatel_e
3200         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3201         dxi=dc(1,i)
3202         dyi=dc(2,i)
3203         dzi=dc(3,i)
3204         dx_normi=dc_norm(1,i)
3205         dy_normi=dc_norm(2,i)
3206         dz_normi=dc_norm(3,i)
3207         xmedi=c(1,i)+0.5d0*dxi
3208         ymedi=c(2,i)+0.5d0*dyi
3209         zmedi=c(3,i)+0.5d0*dzi
3210           xmedi=dmod(xmedi,boxxsize)
3211           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3212           ymedi=dmod(ymedi,boxysize)
3213           if (ymedi.lt.0) ymedi=ymedi+boxysize
3214           zmedi=dmod(zmedi,boxzsize)
3215           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3216        if ((zmedi.gt.bordlipbot)  &
3217         .and.(zmedi.lt.bordliptop)) then
3218 !C the energy transfer exist
3219         if (zmedi.lt.buflipbot) then
3220 !C what fraction I am in
3221          fracinbuf=1.0d0- &
3222              ((zmedi-bordlipbot)/lipbufthick)
3223 !C lipbufthick is thickenes of lipid buffore
3224          sslipi=sscalelip(fracinbuf)
3225          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3226         elseif (zmedi.gt.bufliptop) then
3227          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3228          sslipi=sscalelip(fracinbuf)
3229          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3230         else
3231          sslipi=1.0d0
3232          ssgradlipi=0.0
3233         endif
3234        else
3235          sslipi=0.0d0
3236          ssgradlipi=0.0
3237        endif
3238
3239 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3240         num_conti=num_cont_hb(i)
3241         do j=ielstart(i),ielend(i)
3242 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3243           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3244           call eelecij(i,j,ees,evdw1,eel_loc)
3245         enddo ! j
3246         num_cont_hb(i)=num_conti
3247       enddo   ! i
3248 !      write (iout,*) "Number of loop steps in EELEC:",ind
3249 !d      do i=1,nres
3250 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3251 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3252 !d      enddo
3253 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3254 !cc      eel_loc=eel_loc+eello_turn3
3255 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3256       return
3257       end subroutine eelec
3258 !-----------------------------------------------------------------------------
3259       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3260
3261       use comm_locel
3262 !      implicit real*8 (a-h,o-z)
3263 !      include 'DIMENSIONS'
3264 #ifdef MPI
3265       include "mpif.h"
3266 #endif
3267 !      include 'COMMON.CONTROL'
3268 !      include 'COMMON.IOUNITS'
3269 !      include 'COMMON.GEO'
3270 !      include 'COMMON.VAR'
3271 !      include 'COMMON.LOCAL'
3272 !      include 'COMMON.CHAIN'
3273 !      include 'COMMON.DERIV'
3274 !      include 'COMMON.INTERACT'
3275 !      include 'COMMON.CONTACTS'
3276 !      include 'COMMON.TORSION'
3277 !      include 'COMMON.VECTORS'
3278 !      include 'COMMON.FFIELD'
3279 !      include 'COMMON.TIME1'
3280       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3281       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3282       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3283 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3284       real(kind=8),dimension(4) :: muij
3285       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3286                     dist_temp, dist_init,rlocshield,fracinbuf
3287       integer xshift,yshift,zshift,ilist,iresshield
3288 !el      integer :: num_conti,j1,j2
3289 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3290 !el        dz_normi,xmedi,ymedi,zmedi
3291
3292 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3293 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3294 !el          num_conti,j1,j2
3295
3296 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3297 #ifdef MOMENT
3298       real(kind=8) :: scal_el=1.0d0
3299 #else
3300       real(kind=8) :: scal_el=0.5d0
3301 #endif
3302 ! 12/13/98
3303 ! 13-go grudnia roku pamietnego...
3304       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3305                                              0.0d0,1.0d0,0.0d0,&
3306                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3307 !      integer :: maxconts=nres/4
3308 !el local variables
3309       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3310       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3311       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3312       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3313                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3314                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3315                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3316                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3317                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3318                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3319                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3320 !      maxconts=nres/4
3321 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3322 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3323
3324 !          time00=MPI_Wtime()
3325 !d      write (iout,*) "eelecij",i,j
3326 !          ind=ind+1
3327           iteli=itel(i)
3328           itelj=itel(j)
3329           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3330           aaa=app(iteli,itelj)
3331           bbb=bpp(iteli,itelj)
3332           ael6i=ael6(iteli,itelj)
3333           ael3i=ael3(iteli,itelj)
3334           dxj=dc(1,j)
3335           dyj=dc(2,j)
3336           dzj=dc(3,j)
3337           dx_normj=dc_norm(1,j)
3338           dy_normj=dc_norm(2,j)
3339           dz_normj=dc_norm(3,j)
3340 !          xj=c(1,j)+0.5D0*dxj-xmedi
3341 !          yj=c(2,j)+0.5D0*dyj-ymedi
3342 !          zj=c(3,j)+0.5D0*dzj-zmedi
3343           xj=c(1,j)+0.5D0*dxj
3344           yj=c(2,j)+0.5D0*dyj
3345           zj=c(3,j)+0.5D0*dzj
3346           xj=mod(xj,boxxsize)
3347           if (xj.lt.0) xj=xj+boxxsize
3348           yj=mod(yj,boxysize)
3349           if (yj.lt.0) yj=yj+boxysize
3350           zj=mod(zj,boxzsize)
3351           if (zj.lt.0) zj=zj+boxzsize
3352        if ((zj.gt.bordlipbot)  &
3353        .and.(zj.lt.bordliptop)) then
3354 !C the energy transfer exist
3355         if (zj.lt.buflipbot) then
3356 !C what fraction I am in
3357          fracinbuf=1.0d0-     &
3358              ((zj-bordlipbot)/lipbufthick)
3359 !C lipbufthick is thickenes of lipid buffore
3360          sslipj=sscalelip(fracinbuf)
3361          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3362         elseif (zj.gt.bufliptop) then
3363          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3364          sslipj=sscalelip(fracinbuf)
3365          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3366         else
3367          sslipj=1.0d0
3368          ssgradlipj=0.0
3369         endif
3370        else
3371          sslipj=0.0d0
3372          ssgradlipj=0.0
3373        endif
3374
3375       isubchap=0
3376       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3377       xj_safe=xj
3378       yj_safe=yj
3379       zj_safe=zj
3380       do xshift=-1,1
3381       do yshift=-1,1
3382       do zshift=-1,1
3383           xj=xj_safe+xshift*boxxsize
3384           yj=yj_safe+yshift*boxysize
3385           zj=zj_safe+zshift*boxzsize
3386           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3387           if(dist_temp.lt.dist_init) then
3388             dist_init=dist_temp
3389             xj_temp=xj
3390             yj_temp=yj
3391             zj_temp=zj
3392             isubchap=1
3393           endif
3394        enddo
3395        enddo
3396        enddo
3397        if (isubchap.eq.1) then
3398 !C          print *,i,j
3399           xj=xj_temp-xmedi
3400           yj=yj_temp-ymedi
3401           zj=zj_temp-zmedi
3402        else
3403           xj=xj_safe-xmedi
3404           yj=yj_safe-ymedi
3405           zj=zj_safe-zmedi
3406        endif
3407
3408           rij=xj*xj+yj*yj+zj*zj
3409           rrmij=1.0D0/rij
3410           rij=dsqrt(rij)
3411 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3412             sss_ele_cut=sscale_ele(rij)
3413             sss_ele_grad=sscagrad_ele(rij)
3414 !             sss_ele_cut=1.0d0
3415 !             sss_ele_grad=0.0d0
3416 !            print *,sss_ele_cut,sss_ele_grad,&
3417 !            (rij),r_cut_ele,rlamb_ele
3418 !            if (sss_ele_cut.le.0.0) go to 128
3419
3420           rmij=1.0D0/rij
3421           r3ij=rrmij*rmij
3422           r6ij=r3ij*r3ij
3423           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3424           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3425           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3426           fac=cosa-3.0D0*cosb*cosg
3427           ev1=aaa*r6ij*r6ij
3428 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3429           if (j.eq.i+2) ev1=scal_el*ev1
3430           ev2=bbb*r6ij
3431           fac3=ael6i*r6ij
3432           fac4=ael3i*r3ij
3433           evdwij=ev1+ev2
3434           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3435           el2=fac4*fac
3436 !          eesij=el1+el2
3437           if (shield_mode.gt.0) then
3438 !C          fac_shield(i)=0.4
3439 !C          fac_shield(j)=0.6
3440           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3441           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3442           eesij=(el1+el2)
3443           ees=ees+eesij*sss_ele_cut
3444 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3445 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3446           else
3447           fac_shield(i)=1.0
3448           fac_shield(j)=1.0
3449           eesij=(el1+el2)
3450           ees=ees+eesij   &
3451             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3452 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3453           endif
3454
3455 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3456           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3457 !          ees=ees+eesij*sss_ele_cut
3458           evdw1=evdw1+evdwij*sss_ele_cut  &
3459            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3460 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3461 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3462 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3463 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3464
3465           if (energy_dec) then
3466 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3467 !                  'evdw1',i,j,evdwij,&
3468 !                  iteli,itelj,aaa,evdw1
3469               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3470               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3471           endif
3472 !
3473 ! Calculate contributions to the Cartesian gradient.
3474 !
3475 #ifdef SPLITELE
3476           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3477               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3478           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3479              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3480           fac1=fac
3481           erij(1)=xj*rmij
3482           erij(2)=yj*rmij
3483           erij(3)=zj*rmij
3484 !
3485 ! Radial derivatives. First process both termini of the fragment (i,j)
3486 !
3487           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3488           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3489           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3490            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3491           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3492             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3493
3494           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3495           (shield_mode.gt.0)) then
3496 !C          print *,i,j
3497           do ilist=1,ishield_list(i)
3498            iresshield=shield_list(ilist,i)
3499            do k=1,3
3500            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3501            *2.0*sss_ele_cut
3502            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3503                    rlocshield &
3504             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3505             *sss_ele_cut
3506             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3507            enddo
3508           enddo
3509           do ilist=1,ishield_list(j)
3510            iresshield=shield_list(ilist,j)
3511            do k=1,3
3512            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3513           *2.0*sss_ele_cut
3514            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3515                    rlocshield &
3516            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3517            *sss_ele_cut
3518            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3519            enddo
3520           enddo
3521           do k=1,3
3522             gshieldc(k,i)=gshieldc(k,i)+ &
3523                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3524            *sss_ele_cut
3525
3526             gshieldc(k,j)=gshieldc(k,j)+ &
3527                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3528            *sss_ele_cut
3529
3530             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3531                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3532            *sss_ele_cut
3533
3534             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3535                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3536            *sss_ele_cut
3537
3538            enddo
3539            endif
3540
3541
3542 !          do k=1,3
3543 !            ghalf=0.5D0*ggg(k)
3544 !            gelc(k,i)=gelc(k,i)+ghalf
3545 !            gelc(k,j)=gelc(k,j)+ghalf
3546 !          enddo
3547 ! 9/28/08 AL Gradient compotents will be summed only at the end
3548           do k=1,3
3549             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3550             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3551           enddo
3552             gelc_long(3,j)=gelc_long(3,j)+  &
3553           ssgradlipj*eesij/2.0d0*lipscale**2&
3554            *sss_ele_cut
3555
3556             gelc_long(3,i)=gelc_long(3,i)+  &
3557           ssgradlipi*eesij/2.0d0*lipscale**2&
3558            *sss_ele_cut
3559
3560
3561 !
3562 ! Loop over residues i+1 thru j-1.
3563 !
3564 !grad          do k=i+1,j-1
3565 !grad            do l=1,3
3566 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3567 !grad            enddo
3568 !grad          enddo
3569           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3570            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3571           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3572            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3573           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3574            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3575
3576 !          do k=1,3
3577 !            ghalf=0.5D0*ggg(k)
3578 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3579 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3580 !          enddo
3581 ! 9/28/08 AL Gradient compotents will be summed only at the end
3582           do k=1,3
3583             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3584             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3585           enddo
3586
3587 !C Lipidic part for scaling weight
3588            gvdwpp(3,j)=gvdwpp(3,j)+ &
3589           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3590            gvdwpp(3,i)=gvdwpp(3,i)+ &
3591           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3592 !! Loop over residues i+1 thru j-1.
3593 !
3594 !grad          do k=i+1,j-1
3595 !grad            do l=1,3
3596 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3597 !grad            enddo
3598 !grad          enddo
3599 #else
3600           facvdw=(ev1+evdwij)*sss_ele_cut &
3601            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3602
3603           facel=(el1+eesij)*sss_ele_cut
3604           fac1=fac
3605           fac=-3*rrmij*(facvdw+facvdw+facel)
3606           erij(1)=xj*rmij
3607           erij(2)=yj*rmij
3608           erij(3)=zj*rmij
3609 !
3610 ! Radial derivatives. First process both termini of the fragment (i,j)
3611 !
3612           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3613           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3614           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3615 !          do k=1,3
3616 !            ghalf=0.5D0*ggg(k)
3617 !            gelc(k,i)=gelc(k,i)+ghalf
3618 !            gelc(k,j)=gelc(k,j)+ghalf
3619 !          enddo
3620 ! 9/28/08 AL Gradient compotents will be summed only at the end
3621           do k=1,3
3622             gelc_long(k,j)=gelc(k,j)+ggg(k)
3623             gelc_long(k,i)=gelc(k,i)-ggg(k)
3624           enddo
3625 !
3626 ! Loop over residues i+1 thru j-1.
3627 !
3628 !grad          do k=i+1,j-1
3629 !grad            do l=1,3
3630 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3631 !grad            enddo
3632 !grad          enddo
3633 ! 9/28/08 AL Gradient compotents will be summed only at the end
3634           ggg(1)=facvdw*xj &
3635            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3636           ggg(2)=facvdw*yj &
3637            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3638           ggg(3)=facvdw*zj &
3639            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3640
3641           do k=1,3
3642             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3643             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3644           enddo
3645            gvdwpp(3,j)=gvdwpp(3,j)+ &
3646           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3647            gvdwpp(3,i)=gvdwpp(3,i)+ &
3648           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3649
3650 #endif
3651 !
3652 ! Angular part
3653 !
3654           ecosa=2.0D0*fac3*fac1+fac4
3655           fac4=-3.0D0*fac4
3656           fac3=-6.0D0*fac3
3657           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3658           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3659           do k=1,3
3660             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3661             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3662           enddo
3663 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3664 !d   &          (dcosg(k),k=1,3)
3665           do k=1,3
3666             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3667              *fac_shield(i)**2*fac_shield(j)**2 &
3668              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3669
3670           enddo
3671 !          do k=1,3
3672 !            ghalf=0.5D0*ggg(k)
3673 !            gelc(k,i)=gelc(k,i)+ghalf
3674 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3675 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3676 !            gelc(k,j)=gelc(k,j)+ghalf
3677 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3678 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3679 !          enddo
3680 !grad          do k=i+1,j-1
3681 !grad            do l=1,3
3682 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3683 !grad            enddo
3684 !grad          enddo
3685           do k=1,3
3686             gelc(k,i)=gelc(k,i) &
3687                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3688                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3689                      *sss_ele_cut &
3690                      *fac_shield(i)**2*fac_shield(j)**2 &
3691                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3692
3693             gelc(k,j)=gelc(k,j) &
3694                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3695                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3696                      *sss_ele_cut  &
3697                      *fac_shield(i)**2*fac_shield(j)**2  &
3698                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3699
3700             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3701             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3702           enddo
3703
3704           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3705               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3706               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3707 !
3708 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3709 !   energy of a peptide unit is assumed in the form of a second-order
3710 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3711 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3712 !   are computed for EVERY pair of non-contiguous peptide groups.
3713 !
3714           if (j.lt.nres-1) then
3715             j1=j+1
3716             j2=j-1
3717           else
3718             j1=j-1
3719             j2=j-2
3720           endif
3721           kkk=0
3722           do k=1,2
3723             do l=1,2
3724               kkk=kkk+1
3725               muij(kkk)=mu(k,i)*mu(l,j)
3726             enddo
3727           enddo
3728 !d         write (iout,*) 'EELEC: i',i,' j',j
3729 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3730 !d          write(iout,*) 'muij',muij
3731           ury=scalar(uy(1,i),erij)
3732           urz=scalar(uz(1,i),erij)
3733           vry=scalar(uy(1,j),erij)
3734           vrz=scalar(uz(1,j),erij)
3735           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3736           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3737           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3738           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3739           fac=dsqrt(-ael6i)*r3ij
3740           a22=a22*fac
3741           a23=a23*fac
3742           a32=a32*fac
3743           a33=a33*fac
3744 !d          write (iout,'(4i5,4f10.5)')
3745 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3746 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3747 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3748 !d     &      uy(:,j),uz(:,j)
3749 !d          write (iout,'(4f10.5)')
3750 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3751 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3752 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3753 !d           write (iout,'(9f10.5/)')
3754 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3755 ! Derivatives of the elements of A in virtual-bond vectors
3756           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3757           do k=1,3
3758             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3759             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3760             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3761             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3762             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3763             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3764             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3765             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3766             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3767             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3768             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3769             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3770           enddo
3771 ! Compute radial contributions to the gradient
3772           facr=-3.0d0*rrmij
3773           a22der=a22*facr
3774           a23der=a23*facr
3775           a32der=a32*facr
3776           a33der=a33*facr
3777           agg(1,1)=a22der*xj
3778           agg(2,1)=a22der*yj
3779           agg(3,1)=a22der*zj
3780           agg(1,2)=a23der*xj
3781           agg(2,2)=a23der*yj
3782           agg(3,2)=a23der*zj
3783           agg(1,3)=a32der*xj
3784           agg(2,3)=a32der*yj
3785           agg(3,3)=a32der*zj
3786           agg(1,4)=a33der*xj
3787           agg(2,4)=a33der*yj
3788           agg(3,4)=a33der*zj
3789 ! Add the contributions coming from er
3790           fac3=-3.0d0*fac
3791           do k=1,3
3792             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3793             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3794             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3795             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3796           enddo
3797           do k=1,3
3798 ! Derivatives in DC(i)
3799 !grad            ghalf1=0.5d0*agg(k,1)
3800 !grad            ghalf2=0.5d0*agg(k,2)
3801 !grad            ghalf3=0.5d0*agg(k,3)
3802 !grad            ghalf4=0.5d0*agg(k,4)
3803             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3804             -3.0d0*uryg(k,2)*vry)!+ghalf1
3805             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3806             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3807             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3808             -3.0d0*urzg(k,2)*vry)!+ghalf3
3809             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3810             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3811 ! Derivatives in DC(i+1)
3812             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3813             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3814             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3815             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3816             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3817             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3818             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3819             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3820 ! Derivatives in DC(j)
3821             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3822             -3.0d0*vryg(k,2)*ury)!+ghalf1
3823             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3824             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3825             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3826             -3.0d0*vryg(k,2)*urz)!+ghalf3
3827             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3828             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3829 ! Derivatives in DC(j+1) or DC(nres-1)
3830             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3831             -3.0d0*vryg(k,3)*ury)
3832             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3833             -3.0d0*vrzg(k,3)*ury)
3834             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3835             -3.0d0*vryg(k,3)*urz)
3836             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3837             -3.0d0*vrzg(k,3)*urz)
3838 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3839 !grad              do l=1,4
3840 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3841 !grad              enddo
3842 !grad            endif
3843           enddo
3844           acipa(1,1)=a22
3845           acipa(1,2)=a23
3846           acipa(2,1)=a32
3847           acipa(2,2)=a33
3848           a22=-a22
3849           a23=-a23
3850           do l=1,2
3851             do k=1,3
3852               agg(k,l)=-agg(k,l)
3853               aggi(k,l)=-aggi(k,l)
3854               aggi1(k,l)=-aggi1(k,l)
3855               aggj(k,l)=-aggj(k,l)
3856               aggj1(k,l)=-aggj1(k,l)
3857             enddo
3858           enddo
3859           if (j.lt.nres-1) then
3860             a22=-a22
3861             a32=-a32
3862             do l=1,3,2
3863               do k=1,3
3864                 agg(k,l)=-agg(k,l)
3865                 aggi(k,l)=-aggi(k,l)
3866                 aggi1(k,l)=-aggi1(k,l)
3867                 aggj(k,l)=-aggj(k,l)
3868                 aggj1(k,l)=-aggj1(k,l)
3869               enddo
3870             enddo
3871           else
3872             a22=-a22
3873             a23=-a23
3874             a32=-a32
3875             a33=-a33
3876             do l=1,4
3877               do k=1,3
3878                 agg(k,l)=-agg(k,l)
3879                 aggi(k,l)=-aggi(k,l)
3880                 aggi1(k,l)=-aggi1(k,l)
3881                 aggj(k,l)=-aggj(k,l)
3882                 aggj1(k,l)=-aggj1(k,l)
3883               enddo
3884             enddo
3885           endif
3886           ENDIF ! WCORR
3887           IF (wel_loc.gt.0.0d0) THEN
3888 ! Contribution to the local-electrostatic energy coming from the i-j pair
3889           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3890            +a33*muij(4)
3891           if (shield_mode.eq.0) then
3892            fac_shield(i)=1.0
3893            fac_shield(j)=1.0
3894           endif
3895           eel_loc_ij=eel_loc_ij &
3896          *fac_shield(i)*fac_shield(j) &
3897          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3898 !C Now derivative over eel_loc
3899           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3900          (shield_mode.gt.0)) then
3901 !C          print *,i,j
3902
3903           do ilist=1,ishield_list(i)
3904            iresshield=shield_list(ilist,i)
3905            do k=1,3
3906            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3907                                                 /fac_shield(i)&
3908            *sss_ele_cut
3909            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3910                    rlocshield  &
3911           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3912           *sss_ele_cut
3913
3914             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3915            +rlocshield
3916            enddo
3917           enddo
3918           do ilist=1,ishield_list(j)
3919            iresshield=shield_list(ilist,j)
3920            do k=1,3
3921            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3922                                             /fac_shield(j)   &
3923             *sss_ele_cut
3924            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3925                    rlocshield  &
3926       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3927        *sss_ele_cut
3928
3929            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3930                   +rlocshield
3931
3932            enddo
3933           enddo
3934
3935           do k=1,3
3936             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3937                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3938                     *sss_ele_cut
3939             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3940                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3941                     *sss_ele_cut
3942             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3943                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3944                     *sss_ele_cut
3945             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3946                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3947                     *sss_ele_cut
3948
3949            enddo
3950            endif
3951
3952
3953 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3954 !           eel_loc_ij=0.0
3955           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3956                   'eelloc',i,j,eel_loc_ij
3957 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3958 !          if (energy_dec) write (iout,*) "muij",muij
3959 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3960
3961           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3962 ! Partial derivatives in virtual-bond dihedral angles gamma
3963           if (i.gt.1) &
3964           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3965                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3966                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3967                  *sss_ele_cut  &
3968           *fac_shield(i)*fac_shield(j) &
3969           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3970
3971           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3972                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3973                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3974                  *sss_ele_cut &
3975           *fac_shield(i)*fac_shield(j) &
3976           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3977 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3978 !          do l=1,3
3979 !            ggg(1)=(agg(1,1)*muij(1)+ &
3980 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3981 !            *sss_ele_cut &
3982 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3983 !            ggg(2)=(agg(2,1)*muij(1)+ &
3984 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3985 !            *sss_ele_cut &
3986 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3987 !            ggg(3)=(agg(3,1)*muij(1)+ &
3988 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3989 !            *sss_ele_cut &
3990 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3991            xtemp(1)=xj
3992            xtemp(2)=yj
3993            xtemp(3)=zj
3994
3995            do l=1,3
3996             ggg(l)=(agg(l,1)*muij(1)+ &
3997                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3998             *sss_ele_cut &
3999           *fac_shield(i)*fac_shield(j) &
4000           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4001              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4002
4003
4004             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4005             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4006 !grad            ghalf=0.5d0*ggg(l)
4007 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4008 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4009           enddo
4010             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4011           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4012           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4013
4014             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4015           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4016           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4017
4018 !grad          do k=i+1,j2
4019 !grad            do l=1,3
4020 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4021 !grad            enddo
4022 !grad          enddo
4023 ! Remaining derivatives of eello
4024           do l=1,3
4025             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4026                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4027             *sss_ele_cut &
4028           *fac_shield(i)*fac_shield(j) &
4029           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4030
4031 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4032             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4033                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4034             +aggi1(l,4)*muij(4))&
4035             *sss_ele_cut &
4036           *fac_shield(i)*fac_shield(j) &
4037           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4038
4039 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4040             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4041                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4042             *sss_ele_cut &
4043           *fac_shield(i)*fac_shield(j) &
4044           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4045
4046 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4047             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4048                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4049             +aggj1(l,4)*muij(4))&
4050             *sss_ele_cut &
4051           *fac_shield(i)*fac_shield(j) &
4052           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4053
4054 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4055           enddo
4056           ENDIF
4057 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4058 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4059           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4060              .and. num_conti.le.maxconts) then
4061 !            write (iout,*) i,j," entered corr"
4062 !
4063 ! Calculate the contact function. The ith column of the array JCONT will
4064 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4065 ! greater than I). The arrays FACONT and GACONT will contain the values of
4066 ! the contact function and its derivative.
4067 !           r0ij=1.02D0*rpp(iteli,itelj)
4068 !           r0ij=1.11D0*rpp(iteli,itelj)
4069             r0ij=2.20D0*rpp(iteli,itelj)
4070 !           r0ij=1.55D0*rpp(iteli,itelj)
4071             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4072 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4073             if (fcont.gt.0.0D0) then
4074               num_conti=num_conti+1
4075               if (num_conti.gt.maxconts) then
4076 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4077 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4078                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4079                                ' will skip next contacts for this conf.', num_conti
4080               else
4081                 jcont_hb(num_conti,i)=j
4082 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4083 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4084                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4085                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4086 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4087 !  terms.
4088                 d_cont(num_conti,i)=rij
4089 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4090 !     --- Electrostatic-interaction matrix ---
4091                 a_chuj(1,1,num_conti,i)=a22
4092                 a_chuj(1,2,num_conti,i)=a23
4093                 a_chuj(2,1,num_conti,i)=a32
4094                 a_chuj(2,2,num_conti,i)=a33
4095 !     --- Gradient of rij
4096                 do kkk=1,3
4097                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4098                 enddo
4099                 kkll=0
4100                 do k=1,2
4101                   do l=1,2
4102                     kkll=kkll+1
4103                     do m=1,3
4104                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4105                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4106                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4107                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4108                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4109                     enddo
4110                   enddo
4111                 enddo
4112                 ENDIF
4113                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4114 ! Calculate contact energies
4115                 cosa4=4.0D0*cosa
4116                 wij=cosa-3.0D0*cosb*cosg
4117                 cosbg1=cosb+cosg
4118                 cosbg2=cosb-cosg
4119 !               fac3=dsqrt(-ael6i)/r0ij**3
4120                 fac3=dsqrt(-ael6i)*r3ij
4121 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4122                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4123                 if (ees0tmp.gt.0) then
4124                   ees0pij=dsqrt(ees0tmp)
4125                 else
4126                   ees0pij=0
4127                 endif
4128                 if (shield_mode.eq.0) then
4129                 fac_shield(i)=1.0d0
4130                 fac_shield(j)=1.0d0
4131                 else
4132                 ees0plist(num_conti,i)=j
4133                 endif
4134 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4135                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4136                 if (ees0tmp.gt.0) then
4137                   ees0mij=dsqrt(ees0tmp)
4138                 else
4139                   ees0mij=0
4140                 endif
4141 !               ees0mij=0.0D0
4142                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4143                      *sss_ele_cut &
4144                      *fac_shield(i)*fac_shield(j)
4145
4146                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4147                      *sss_ele_cut &
4148                      *fac_shield(i)*fac_shield(j)
4149
4150 ! Diagnostics. Comment out or remove after debugging!
4151 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4152 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4153 !               ees0m(num_conti,i)=0.0D0
4154 ! End diagnostics.
4155 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4156 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4157 ! Angular derivatives of the contact function
4158                 ees0pij1=fac3/ees0pij
4159                 ees0mij1=fac3/ees0mij
4160                 fac3p=-3.0D0*fac3*rrmij
4161                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4162                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4163 !               ees0mij1=0.0D0
4164                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4165                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4166                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4167                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4168                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4169                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4170                 ecosap=ecosa1+ecosa2
4171                 ecosbp=ecosb1+ecosb2
4172                 ecosgp=ecosg1+ecosg2
4173                 ecosam=ecosa1-ecosa2
4174                 ecosbm=ecosb1-ecosb2
4175                 ecosgm=ecosg1-ecosg2
4176 ! Diagnostics
4177 !               ecosap=ecosa1
4178 !               ecosbp=ecosb1
4179 !               ecosgp=ecosg1
4180 !               ecosam=0.0D0
4181 !               ecosbm=0.0D0
4182 !               ecosgm=0.0D0
4183 ! End diagnostics
4184                 facont_hb(num_conti,i)=fcont
4185                 fprimcont=fprimcont/rij
4186 !d              facont_hb(num_conti,i)=1.0D0
4187 ! Following line is for diagnostics.
4188 !d              fprimcont=0.0D0
4189                 do k=1,3
4190                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4191                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4192                 enddo
4193                 do k=1,3
4194                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4195                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4196                 enddo
4197                 gggp(1)=gggp(1)+ees0pijp*xj &
4198                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4199                 gggp(2)=gggp(2)+ees0pijp*yj &
4200                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4201                 gggp(3)=gggp(3)+ees0pijp*zj &
4202                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4203
4204                 gggm(1)=gggm(1)+ees0mijp*xj &
4205                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4206
4207                 gggm(2)=gggm(2)+ees0mijp*yj &
4208                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4209
4210                 gggm(3)=gggm(3)+ees0mijp*zj &
4211                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4212
4213 ! Derivatives due to the contact function
4214                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4215                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4216                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4217                 do k=1,3
4218 !
4219 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4220 !          following the change of gradient-summation algorithm.
4221 !
4222 !grad                  ghalfp=0.5D0*gggp(k)
4223 !grad                  ghalfm=0.5D0*gggm(k)
4224                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4225                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4226                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4227                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4228
4229                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4230                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4231                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4232                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4233
4234                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4235                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4236
4237                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4238                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4239                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4240                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4241
4242                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4243                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4244                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4245                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4246
4247                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4248                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4249
4250                 enddo
4251 ! Diagnostics. Comment out or remove after debugging!
4252 !diag           do k=1,3
4253 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4254 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4255 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4256 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4257 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4258 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4259 !diag           enddo
4260               ENDIF ! wcorr
4261               endif  ! num_conti.le.maxconts
4262             endif  ! fcont.gt.0
4263           endif    ! j.gt.i+1
4264           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4265             do k=1,4
4266               do l=1,3
4267                 ghalf=0.5d0*agg(l,k)
4268                 aggi(l,k)=aggi(l,k)+ghalf
4269                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4270                 aggj(l,k)=aggj(l,k)+ghalf
4271               enddo
4272             enddo
4273             if (j.eq.nres-1 .and. i.lt.j-2) then
4274               do k=1,4
4275                 do l=1,3
4276                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4277                 enddo
4278               enddo
4279             endif
4280           endif
4281  128  continue
4282 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4283       return
4284       end subroutine eelecij
4285 !-----------------------------------------------------------------------------
4286       subroutine eturn3(i,eello_turn3)
4287 ! Third- and fourth-order contributions from turns
4288
4289       use comm_locel
4290 !      implicit real*8 (a-h,o-z)
4291 !      include 'DIMENSIONS'
4292 !      include 'COMMON.IOUNITS'
4293 !      include 'COMMON.GEO'
4294 !      include 'COMMON.VAR'
4295 !      include 'COMMON.LOCAL'
4296 !      include 'COMMON.CHAIN'
4297 !      include 'COMMON.DERIV'
4298 !      include 'COMMON.INTERACT'
4299 !      include 'COMMON.CONTACTS'
4300 !      include 'COMMON.TORSION'
4301 !      include 'COMMON.VECTORS'
4302 !      include 'COMMON.FFIELD'
4303 !      include 'COMMON.CONTROL'
4304       real(kind=8),dimension(3) :: ggg
4305       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4306         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4307       real(kind=8),dimension(2) :: auxvec,auxvec1
4308 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4309       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4310 !el      integer :: num_conti,j1,j2
4311 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4312 !el        dz_normi,xmedi,ymedi,zmedi
4313
4314 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4315 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4316 !el         num_conti,j1,j2
4317 !el local variables
4318       integer :: i,j,l,k,ilist,iresshield
4319       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4320
4321       j=i+2
4322 !      write (iout,*) "eturn3",i,j,j1,j2
4323           zj=(c(3,j)+c(3,j+1))/2.0d0
4324           zj=mod(zj,boxzsize)
4325           if (zj.lt.0) zj=zj+boxzsize
4326           if ((zj.lt.0)) write (*,*) "CHUJ"
4327        if ((zj.gt.bordlipbot)  &
4328         .and.(zj.lt.bordliptop)) then
4329 !C the energy transfer exist
4330         if (zj.lt.buflipbot) then
4331 !C what fraction I am in
4332          fracinbuf=1.0d0-     &
4333              ((zj-bordlipbot)/lipbufthick)
4334 !C lipbufthick is thickenes of lipid buffore
4335          sslipj=sscalelip(fracinbuf)
4336          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4337         elseif (zj.gt.bufliptop) then
4338          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4339          sslipj=sscalelip(fracinbuf)
4340          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4341         else
4342          sslipj=1.0d0
4343          ssgradlipj=0.0
4344         endif
4345        else
4346          sslipj=0.0d0
4347          ssgradlipj=0.0
4348        endif
4349
4350       a_temp(1,1)=a22
4351       a_temp(1,2)=a23
4352       a_temp(2,1)=a32
4353       a_temp(2,2)=a33
4354 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4355 !
4356 !               Third-order contributions
4357 !
4358 !                 (i+2)o----(i+3)
4359 !                      | |
4360 !                      | |
4361 !                 (i+1)o----i
4362 !
4363 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4364 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4365         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4366         call transpose2(auxmat(1,1),auxmat1(1,1))
4367         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4368         if (shield_mode.eq.0) then
4369         fac_shield(i)=1.0d0
4370         fac_shield(j)=1.0d0
4371         endif
4372
4373         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4374          *fac_shield(i)*fac_shield(j)  &
4375          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4376         eello_t3= &
4377         0.5d0*(pizda(1,1)+pizda(2,2)) &
4378         *fac_shield(i)*fac_shield(j)
4379
4380         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4381                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4382           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4383        (shield_mode.gt.0)) then
4384 !C          print *,i,j
4385
4386           do ilist=1,ishield_list(i)
4387            iresshield=shield_list(ilist,i)
4388            do k=1,3
4389            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4390            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4391                    rlocshield &
4392            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4393             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4394              +rlocshield
4395            enddo
4396           enddo
4397           do ilist=1,ishield_list(j)
4398            iresshield=shield_list(ilist,j)
4399            do k=1,3
4400            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4401            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4402                    rlocshield &
4403            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4404            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4405                   +rlocshield
4406
4407            enddo
4408           enddo
4409
4410           do k=1,3
4411             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4412                    grad_shield(k,i)*eello_t3/fac_shield(i)
4413             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4414                    grad_shield(k,j)*eello_t3/fac_shield(j)
4415             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4416                    grad_shield(k,i)*eello_t3/fac_shield(i)
4417             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4418                    grad_shield(k,j)*eello_t3/fac_shield(j)
4419            enddo
4420            endif
4421
4422 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4423 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4424 !d     &    ' eello_turn3_num',4*eello_turn3_num
4425 ! Derivatives in gamma(i)
4426         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4427         call transpose2(auxmat2(1,1),auxmat3(1,1))
4428         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4429         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4430           *fac_shield(i)*fac_shield(j)        &
4431           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4432 ! Derivatives in gamma(i+1)
4433         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4434         call transpose2(auxmat2(1,1),auxmat3(1,1))
4435         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4436         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4437           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4438           *fac_shield(i)*fac_shield(j)        &
4439           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4440
4441 ! Cartesian derivatives
4442         do l=1,3
4443 !            ghalf1=0.5d0*agg(l,1)
4444 !            ghalf2=0.5d0*agg(l,2)
4445 !            ghalf3=0.5d0*agg(l,3)
4446 !            ghalf4=0.5d0*agg(l,4)
4447           a_temp(1,1)=aggi(l,1)!+ghalf1
4448           a_temp(1,2)=aggi(l,2)!+ghalf2
4449           a_temp(2,1)=aggi(l,3)!+ghalf3
4450           a_temp(2,2)=aggi(l,4)!+ghalf4
4451           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4452           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4453             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4454           *fac_shield(i)*fac_shield(j)      &
4455           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4456
4457           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4458           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4459           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4460           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4461           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4462           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4463             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4464           *fac_shield(i)*fac_shield(j)        &
4465           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4466
4467           a_temp(1,1)=aggj(l,1)!+ghalf1
4468           a_temp(1,2)=aggj(l,2)!+ghalf2
4469           a_temp(2,1)=aggj(l,3)!+ghalf3
4470           a_temp(2,2)=aggj(l,4)!+ghalf4
4471           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4472           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4473             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4474           *fac_shield(i)*fac_shield(j)      &
4475           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4476
4477           a_temp(1,1)=aggj1(l,1)
4478           a_temp(1,2)=aggj1(l,2)
4479           a_temp(2,1)=aggj1(l,3)
4480           a_temp(2,2)=aggj1(l,4)
4481           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4482           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4483             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4484           *fac_shield(i)*fac_shield(j)        &
4485           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4486         enddo
4487          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4488           ssgradlipi*eello_t3/4.0d0*lipscale
4489          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4490           ssgradlipj*eello_t3/4.0d0*lipscale
4491          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4492           ssgradlipi*eello_t3/4.0d0*lipscale
4493          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4494           ssgradlipj*eello_t3/4.0d0*lipscale
4495
4496       return
4497       end subroutine eturn3
4498 !-----------------------------------------------------------------------------
4499       subroutine eturn4(i,eello_turn4)
4500 ! Third- and fourth-order contributions from turns
4501
4502       use comm_locel
4503 !      implicit real*8 (a-h,o-z)
4504 !      include 'DIMENSIONS'
4505 !      include 'COMMON.IOUNITS'
4506 !      include 'COMMON.GEO'
4507 !      include 'COMMON.VAR'
4508 !      include 'COMMON.LOCAL'
4509 !      include 'COMMON.CHAIN'
4510 !      include 'COMMON.DERIV'
4511 !      include 'COMMON.INTERACT'
4512 !      include 'COMMON.CONTACTS'
4513 !      include 'COMMON.TORSION'
4514 !      include 'COMMON.VECTORS'
4515 !      include 'COMMON.FFIELD'
4516 !      include 'COMMON.CONTROL'
4517       real(kind=8),dimension(3) :: ggg
4518       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4519         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4520       real(kind=8),dimension(2) :: auxvec,auxvec1
4521 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4522       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4523 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4524 !el        dz_normi,xmedi,ymedi,zmedi
4525 !el      integer :: num_conti,j1,j2
4526 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4527 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4528 !el          num_conti,j1,j2
4529 !el local variables
4530       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4531       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4532          rlocshield
4533
4534       j=i+3
4535 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4536 !
4537 !               Fourth-order contributions
4538 !
4539 !                 (i+3)o----(i+4)
4540 !                     /  |
4541 !               (i+2)o   |
4542 !                     \  |
4543 !                 (i+1)o----i
4544 !
4545 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4546 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4547 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4548           zj=(c(3,j)+c(3,j+1))/2.0d0
4549           zj=mod(zj,boxzsize)
4550           if (zj.lt.0) zj=zj+boxzsize
4551        if ((zj.gt.bordlipbot)  &
4552         .and.(zj.lt.bordliptop)) then
4553 !C the energy transfer exist
4554         if (zj.lt.buflipbot) then
4555 !C what fraction I am in
4556          fracinbuf=1.0d0-     &
4557              ((zj-bordlipbot)/lipbufthick)
4558 !C lipbufthick is thickenes of lipid buffore
4559          sslipj=sscalelip(fracinbuf)
4560          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4561         elseif (zj.gt.bufliptop) then
4562          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4563          sslipj=sscalelip(fracinbuf)
4564          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4565         else
4566          sslipj=1.0d0
4567          ssgradlipj=0.0
4568         endif
4569        else
4570          sslipj=0.0d0
4571          ssgradlipj=0.0
4572        endif
4573
4574         a_temp(1,1)=a22
4575         a_temp(1,2)=a23
4576         a_temp(2,1)=a32
4577         a_temp(2,2)=a33
4578         iti1=itortyp(itype(i+1,1))
4579         iti2=itortyp(itype(i+2,1))
4580         iti3=itortyp(itype(i+3,1))
4581 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4582         call transpose2(EUg(1,1,i+1),e1t(1,1))
4583         call transpose2(Eug(1,1,i+2),e2t(1,1))
4584         call transpose2(Eug(1,1,i+3),e3t(1,1))
4585         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4586         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4587         s1=scalar2(b1(1,iti2),auxvec(1))
4588         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4589         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4590         s2=scalar2(b1(1,iti1),auxvec(1))
4591         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4592         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4593         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4594         if (shield_mode.eq.0) then
4595         fac_shield(i)=1.0
4596         fac_shield(j)=1.0
4597         endif
4598
4599         eello_turn4=eello_turn4-(s1+s2+s3) &
4600         *fac_shield(i)*fac_shield(j)       &
4601         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4602         eello_t4=-(s1+s2+s3)  &
4603           *fac_shield(i)*fac_shield(j)
4604 !C Now derivative over shield:
4605           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4606          (shield_mode.gt.0)) then
4607 !C          print *,i,j
4608
4609           do ilist=1,ishield_list(i)
4610            iresshield=shield_list(ilist,i)
4611            do k=1,3
4612            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4613            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4614                    rlocshield &
4615             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4616             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4617            +rlocshield
4618            enddo
4619           enddo
4620           do ilist=1,ishield_list(j)
4621            iresshield=shield_list(ilist,j)
4622            do k=1,3
4623            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4624            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4625                    rlocshield  &
4626            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4627            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4628                   +rlocshield
4629
4630            enddo
4631           enddo
4632
4633           do k=1,3
4634             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4635                    grad_shield(k,i)*eello_t4/fac_shield(i)
4636             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4637                    grad_shield(k,j)*eello_t4/fac_shield(j)
4638             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4639                    grad_shield(k,i)*eello_t4/fac_shield(i)
4640             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4641                    grad_shield(k,j)*eello_t4/fac_shield(j)
4642            enddo
4643            endif
4644
4645         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4646            'eturn4',i,j,-(s1+s2+s3)
4647 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4648 !d     &    ' eello_turn4_num',8*eello_turn4_num
4649 ! Derivatives in gamma(i)
4650         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4651         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4652         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4653         s1=scalar2(b1(1,iti2),auxvec(1))
4654         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4655         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4656         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4657        *fac_shield(i)*fac_shield(j)  &
4658        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4659
4660 ! Derivatives in gamma(i+1)
4661         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4662         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4663         s2=scalar2(b1(1,iti1),auxvec(1))
4664         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4665         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4666         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4667         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4668        *fac_shield(i)*fac_shield(j)  &
4669        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4670
4671 ! Derivatives in gamma(i+2)
4672         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4673         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4674         s1=scalar2(b1(1,iti2),auxvec(1))
4675         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4676         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4677         s2=scalar2(b1(1,iti1),auxvec(1))
4678         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4679         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4680         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4681         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4682        *fac_shield(i)*fac_shield(j)  &
4683        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4684
4685 ! Cartesian derivatives
4686 ! Derivatives of this turn contributions in DC(i+2)
4687         if (j.lt.nres-1) then
4688           do l=1,3
4689             a_temp(1,1)=agg(l,1)
4690             a_temp(1,2)=agg(l,2)
4691             a_temp(2,1)=agg(l,3)
4692             a_temp(2,2)=agg(l,4)
4693             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4694             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4695             s1=scalar2(b1(1,iti2),auxvec(1))
4696             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4697             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4698             s2=scalar2(b1(1,iti1),auxvec(1))
4699             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4700             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4701             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4702             ggg(l)=-(s1+s2+s3)
4703             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4704        *fac_shield(i)*fac_shield(j)  &
4705        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4706
4707           enddo
4708         endif
4709 ! Remaining derivatives of this turn contribution
4710         do l=1,3
4711           a_temp(1,1)=aggi(l,1)
4712           a_temp(1,2)=aggi(l,2)
4713           a_temp(2,1)=aggi(l,3)
4714           a_temp(2,2)=aggi(l,4)
4715           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4716           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4717           s1=scalar2(b1(1,iti2),auxvec(1))
4718           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4719           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4720           s2=scalar2(b1(1,iti1),auxvec(1))
4721           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4722           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4723           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4724           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4725          *fac_shield(i)*fac_shield(j)  &
4726          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4727
4728
4729           a_temp(1,1)=aggi1(l,1)
4730           a_temp(1,2)=aggi1(l,2)
4731           a_temp(2,1)=aggi1(l,3)
4732           a_temp(2,2)=aggi1(l,4)
4733           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4734           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4735           s1=scalar2(b1(1,iti2),auxvec(1))
4736           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4737           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4738           s2=scalar2(b1(1,iti1),auxvec(1))
4739           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4740           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4741           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4742           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4743          *fac_shield(i)*fac_shield(j)  &
4744          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4745
4746
4747           a_temp(1,1)=aggj(l,1)
4748           a_temp(1,2)=aggj(l,2)
4749           a_temp(2,1)=aggj(l,3)
4750           a_temp(2,2)=aggj(l,4)
4751           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4752           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4753           s1=scalar2(b1(1,iti2),auxvec(1))
4754           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4755           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4756           s2=scalar2(b1(1,iti1),auxvec(1))
4757           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4758           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4759           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4760           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4761          *fac_shield(i)*fac_shield(j)  &
4762          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4763
4764
4765           a_temp(1,1)=aggj1(l,1)
4766           a_temp(1,2)=aggj1(l,2)
4767           a_temp(2,1)=aggj1(l,3)
4768           a_temp(2,2)=aggj1(l,4)
4769           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4770           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4771           s1=scalar2(b1(1,iti2),auxvec(1))
4772           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4773           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4774           s2=scalar2(b1(1,iti1),auxvec(1))
4775           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4776           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4777           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4778 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4779           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4780          *fac_shield(i)*fac_shield(j)  &
4781          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4782
4783         enddo
4784          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4785           ssgradlipi*eello_t4/4.0d0*lipscale
4786          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4787           ssgradlipj*eello_t4/4.0d0*lipscale
4788          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4789           ssgradlipi*eello_t4/4.0d0*lipscale
4790          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4791           ssgradlipj*eello_t4/4.0d0*lipscale
4792
4793       return
4794       end subroutine eturn4
4795 !-----------------------------------------------------------------------------
4796       subroutine unormderiv(u,ugrad,unorm,ungrad)
4797 ! This subroutine computes the derivatives of a normalized vector u, given
4798 ! the derivatives computed without normalization conditions, ugrad. Returns
4799 ! ungrad.
4800 !      implicit none
4801       real(kind=8),dimension(3) :: u,vec
4802       real(kind=8),dimension(3,3) ::ugrad,ungrad
4803       real(kind=8) :: unorm      !,scalar
4804       integer :: i,j
4805 !      write (2,*) 'ugrad',ugrad
4806 !      write (2,*) 'u',u
4807       do i=1,3
4808         vec(i)=scalar(ugrad(1,i),u(1))
4809       enddo
4810 !      write (2,*) 'vec',vec
4811       do i=1,3
4812         do j=1,3
4813           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4814         enddo
4815       enddo
4816 !      write (2,*) 'ungrad',ungrad
4817       return
4818       end subroutine unormderiv
4819 !-----------------------------------------------------------------------------
4820       subroutine escp_soft_sphere(evdw2,evdw2_14)
4821 !
4822 ! This subroutine calculates the excluded-volume interaction energy between
4823 ! peptide-group centers and side chains and its gradient in virtual-bond and
4824 ! side-chain vectors.
4825 !
4826 !      implicit real*8 (a-h,o-z)
4827 !      include 'DIMENSIONS'
4828 !      include 'COMMON.GEO'
4829 !      include 'COMMON.VAR'
4830 !      include 'COMMON.LOCAL'
4831 !      include 'COMMON.CHAIN'
4832 !      include 'COMMON.DERIV'
4833 !      include 'COMMON.INTERACT'
4834 !      include 'COMMON.FFIELD'
4835 !      include 'COMMON.IOUNITS'
4836 !      include 'COMMON.CONTROL'
4837       real(kind=8),dimension(3) :: ggg
4838 !el local variables
4839       integer :: i,iint,j,k,iteli,itypj
4840       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4841                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4842
4843       evdw2=0.0D0
4844       evdw2_14=0.0d0
4845       r0_scp=4.5d0
4846 !d    print '(a)','Enter ESCP'
4847 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4848       do i=iatscp_s,iatscp_e
4849         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4850         iteli=itel(i)
4851         xi=0.5D0*(c(1,i)+c(1,i+1))
4852         yi=0.5D0*(c(2,i)+c(2,i+1))
4853         zi=0.5D0*(c(3,i)+c(3,i+1))
4854
4855         do iint=1,nscp_gr(i)
4856
4857         do j=iscpstart(i,iint),iscpend(i,iint)
4858           if (itype(j,1).eq.ntyp1) cycle
4859           itypj=iabs(itype(j,1))
4860 ! Uncomment following three lines for SC-p interactions
4861 !         xj=c(1,nres+j)-xi
4862 !         yj=c(2,nres+j)-yi
4863 !         zj=c(3,nres+j)-zi
4864 ! Uncomment following three lines for Ca-p interactions
4865           xj=c(1,j)-xi
4866           yj=c(2,j)-yi
4867           zj=c(3,j)-zi
4868           rij=xj*xj+yj*yj+zj*zj
4869           r0ij=r0_scp
4870           r0ijsq=r0ij*r0ij
4871           if (rij.lt.r0ijsq) then
4872             evdwij=0.25d0*(rij-r0ijsq)**2
4873             fac=rij-r0ijsq
4874           else
4875             evdwij=0.0d0
4876             fac=0.0d0
4877           endif
4878           evdw2=evdw2+evdwij
4879 !
4880 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4881 !
4882           ggg(1)=xj*fac
4883           ggg(2)=yj*fac
4884           ggg(3)=zj*fac
4885 !grad          if (j.lt.i) then
4886 !d          write (iout,*) 'j<i'
4887 ! Uncomment following three lines for SC-p interactions
4888 !           do k=1,3
4889 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4890 !           enddo
4891 !grad          else
4892 !d          write (iout,*) 'j>i'
4893 !grad            do k=1,3
4894 !grad              ggg(k)=-ggg(k)
4895 ! Uncomment following line for SC-p interactions
4896 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4897 !grad            enddo
4898 !grad          endif
4899 !grad          do k=1,3
4900 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4901 !grad          enddo
4902 !grad          kstart=min0(i+1,j)
4903 !grad          kend=max0(i-1,j-1)
4904 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4905 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4906 !grad          do k=kstart,kend
4907 !grad            do l=1,3
4908 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4909 !grad            enddo
4910 !grad          enddo
4911           do k=1,3
4912             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4913             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4914           enddo
4915         enddo
4916
4917         enddo ! iint
4918       enddo ! i
4919       return
4920       end subroutine escp_soft_sphere
4921 !-----------------------------------------------------------------------------
4922       subroutine escp(evdw2,evdw2_14)
4923 !
4924 ! This subroutine calculates the excluded-volume interaction energy between
4925 ! peptide-group centers and side chains and its gradient in virtual-bond and
4926 ! side-chain vectors.
4927 !
4928 !      implicit real*8 (a-h,o-z)
4929 !      include 'DIMENSIONS'
4930 !      include 'COMMON.GEO'
4931 !      include 'COMMON.VAR'
4932 !      include 'COMMON.LOCAL'
4933 !      include 'COMMON.CHAIN'
4934 !      include 'COMMON.DERIV'
4935 !      include 'COMMON.INTERACT'
4936 !      include 'COMMON.FFIELD'
4937 !      include 'COMMON.IOUNITS'
4938 !      include 'COMMON.CONTROL'
4939       real(kind=8),dimension(3) :: ggg
4940 !el local variables
4941       integer :: i,iint,j,k,iteli,itypj,subchap
4942       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4943                    e1,e2,evdwij,rij
4944       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4945                     dist_temp, dist_init
4946       integer xshift,yshift,zshift
4947
4948       evdw2=0.0D0
4949       evdw2_14=0.0d0
4950 !d    print '(a)','Enter ESCP'
4951 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4952       do i=iatscp_s,iatscp_e
4953         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4954         iteli=itel(i)
4955         xi=0.5D0*(c(1,i)+c(1,i+1))
4956         yi=0.5D0*(c(2,i)+c(2,i+1))
4957         zi=0.5D0*(c(3,i)+c(3,i+1))
4958           xi=mod(xi,boxxsize)
4959           if (xi.lt.0) xi=xi+boxxsize
4960           yi=mod(yi,boxysize)
4961           if (yi.lt.0) yi=yi+boxysize
4962           zi=mod(zi,boxzsize)
4963           if (zi.lt.0) zi=zi+boxzsize
4964
4965         do iint=1,nscp_gr(i)
4966
4967         do j=iscpstart(i,iint),iscpend(i,iint)
4968           itypj=iabs(itype(j,1))
4969           if (itypj.eq.ntyp1) cycle
4970 ! Uncomment following three lines for SC-p interactions
4971 !         xj=c(1,nres+j)-xi
4972 !         yj=c(2,nres+j)-yi
4973 !         zj=c(3,nres+j)-zi
4974 ! Uncomment following three lines for Ca-p interactions
4975 !          xj=c(1,j)-xi
4976 !          yj=c(2,j)-yi
4977 !          zj=c(3,j)-zi
4978           xj=c(1,j)
4979           yj=c(2,j)
4980           zj=c(3,j)
4981           xj=mod(xj,boxxsize)
4982           if (xj.lt.0) xj=xj+boxxsize
4983           yj=mod(yj,boxysize)
4984           if (yj.lt.0) yj=yj+boxysize
4985           zj=mod(zj,boxzsize)
4986           if (zj.lt.0) zj=zj+boxzsize
4987       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4988       xj_safe=xj
4989       yj_safe=yj
4990       zj_safe=zj
4991       subchap=0
4992       do xshift=-1,1
4993       do yshift=-1,1
4994       do zshift=-1,1
4995           xj=xj_safe+xshift*boxxsize
4996           yj=yj_safe+yshift*boxysize
4997           zj=zj_safe+zshift*boxzsize
4998           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4999           if(dist_temp.lt.dist_init) then
5000             dist_init=dist_temp
5001             xj_temp=xj
5002             yj_temp=yj
5003             zj_temp=zj
5004             subchap=1
5005           endif
5006        enddo
5007        enddo
5008        enddo
5009        if (subchap.eq.1) then
5010           xj=xj_temp-xi
5011           yj=yj_temp-yi
5012           zj=zj_temp-zi
5013        else
5014           xj=xj_safe-xi
5015           yj=yj_safe-yi
5016           zj=zj_safe-zi
5017        endif
5018
5019           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5020           rij=dsqrt(1.0d0/rrij)
5021             sss_ele_cut=sscale_ele(rij)
5022             sss_ele_grad=sscagrad_ele(rij)
5023 !            print *,sss_ele_cut,sss_ele_grad,&
5024 !            (rij),r_cut_ele,rlamb_ele
5025             if (sss_ele_cut.le.0.0) cycle
5026           fac=rrij**expon2
5027           e1=fac*fac*aad(itypj,iteli)
5028           e2=fac*bad(itypj,iteli)
5029           if (iabs(j-i) .le. 2) then
5030             e1=scal14*e1
5031             e2=scal14*e2
5032             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5033           endif
5034           evdwij=e1+e2
5035           evdw2=evdw2+evdwij*sss_ele_cut
5036 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5037 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5038           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5039              'evdw2',i,j,evdwij
5040 !
5041 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5042 !
5043           fac=-(evdwij+e1)*rrij*sss_ele_cut
5044           fac=fac+evdwij*sss_ele_grad/rij/expon
5045           ggg(1)=xj*fac
5046           ggg(2)=yj*fac
5047           ggg(3)=zj*fac
5048 !grad          if (j.lt.i) then
5049 !d          write (iout,*) 'j<i'
5050 ! Uncomment following three lines for SC-p interactions
5051 !           do k=1,3
5052 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5053 !           enddo
5054 !grad          else
5055 !d          write (iout,*) 'j>i'
5056 !grad            do k=1,3
5057 !grad              ggg(k)=-ggg(k)
5058 ! Uncomment following line for SC-p interactions
5059 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5060 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5061 !grad            enddo
5062 !grad          endif
5063 !grad          do k=1,3
5064 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5065 !grad          enddo
5066 !grad          kstart=min0(i+1,j)
5067 !grad          kend=max0(i-1,j-1)
5068 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5069 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5070 !grad          do k=kstart,kend
5071 !grad            do l=1,3
5072 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5073 !grad            enddo
5074 !grad          enddo
5075           do k=1,3
5076             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5077             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5078           enddo
5079         enddo
5080
5081         enddo ! iint
5082       enddo ! i
5083       do i=1,nct
5084         do j=1,3
5085           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5086           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5087           gradx_scp(j,i)=expon*gradx_scp(j,i)
5088         enddo
5089       enddo
5090 !******************************************************************************
5091 !
5092 !                              N O T E !!!
5093 !
5094 ! To save time the factor EXPON has been extracted from ALL components
5095 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5096 ! use!
5097 !
5098 !******************************************************************************
5099       return
5100       end subroutine escp
5101 !-----------------------------------------------------------------------------
5102       subroutine edis(ehpb)
5103 !
5104 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5105 !
5106 !      implicit real*8 (a-h,o-z)
5107 !      include 'DIMENSIONS'
5108 !      include 'COMMON.SBRIDGE'
5109 !      include 'COMMON.CHAIN'
5110 !      include 'COMMON.DERIV'
5111 !      include 'COMMON.VAR'
5112 !      include 'COMMON.INTERACT'
5113 !      include 'COMMON.IOUNITS'
5114       real(kind=8),dimension(3) :: ggg
5115 !el local variables
5116       integer :: i,j,ii,jj,iii,jjj,k
5117       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5118
5119       ehpb=0.0D0
5120 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5121 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5122       if (link_end.eq.0) return
5123       do i=link_start,link_end
5124 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5125 ! CA-CA distance used in regularization of structure.
5126         ii=ihpb(i)
5127         jj=jhpb(i)
5128 ! iii and jjj point to the residues for which the distance is assigned.
5129         if (ii.gt.nres) then
5130           iii=ii-nres
5131           jjj=jj-nres
5132         else
5133           iii=ii
5134           jjj=jj
5135         endif
5136 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5137 !     &    dhpb(i),dhpb1(i),forcon(i)
5138 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5139 !    distance and angle dependent SS bond potential.
5140 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5141 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5142         if (.not.dyn_ss .and. i.le.nss) then
5143 ! 15/02/13 CC dynamic SSbond - additional check
5144          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5145         iabs(itype(jjj,1)).eq.1) then
5146           call ssbond_ene(iii,jjj,eij)
5147           ehpb=ehpb+2*eij
5148 !d          write (iout,*) "eij",eij
5149          endif
5150         else if (ii.gt.nres .and. jj.gt.nres) then
5151 !c Restraints from contact prediction
5152           dd=dist(ii,jj)
5153           if (constr_dist.eq.11) then
5154             ehpb=ehpb+fordepth(i)**4.0d0 &
5155                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5156             fac=fordepth(i)**4.0d0 &
5157                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5158           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5159             ehpb,fordepth(i),dd
5160            else
5161           if (dhpb1(i).gt.0.0d0) then
5162             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5163             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5164 !c            write (iout,*) "beta nmr",
5165 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5166           else
5167             dd=dist(ii,jj)
5168             rdis=dd-dhpb(i)
5169 !C Get the force constant corresponding to this distance.
5170             waga=forcon(i)
5171 !C Calculate the contribution to energy.
5172             ehpb=ehpb+waga*rdis*rdis
5173 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5174 !C
5175 !C Evaluate gradient.
5176 !C
5177             fac=waga*rdis/dd
5178           endif
5179           endif
5180           do j=1,3
5181             ggg(j)=fac*(c(j,jj)-c(j,ii))
5182           enddo
5183           do j=1,3
5184             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5185             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5186           enddo
5187           do k=1,3
5188             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5189             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5190           enddo
5191         else
5192           dd=dist(ii,jj)
5193           if (constr_dist.eq.11) then
5194             ehpb=ehpb+fordepth(i)**4.0d0 &
5195                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5196             fac=fordepth(i)**4.0d0 &
5197                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5198           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5199          ehpb,fordepth(i),dd
5200            else
5201           if (dhpb1(i).gt.0.0d0) then
5202             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5203             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5204 !c            write (iout,*) "alph nmr",
5205 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5206           else
5207             rdis=dd-dhpb(i)
5208 !C Get the force constant corresponding to this distance.
5209             waga=forcon(i)
5210 !C Calculate the contribution to energy.
5211             ehpb=ehpb+waga*rdis*rdis
5212 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5213 !C
5214 !C Evaluate gradient.
5215 !C
5216             fac=waga*rdis/dd
5217           endif
5218           endif
5219
5220             do j=1,3
5221               ggg(j)=fac*(c(j,jj)-c(j,ii))
5222             enddo
5223 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5224 !C If this is a SC-SC distance, we need to calculate the contributions to the
5225 !C Cartesian gradient in the SC vectors (ghpbx).
5226           if (iii.lt.ii) then
5227           do j=1,3
5228             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5229             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5230           enddo
5231           endif
5232 !cgrad        do j=iii,jjj-1
5233 !cgrad          do k=1,3
5234 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5235 !cgrad          enddo
5236 !cgrad        enddo
5237           do k=1,3
5238             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5239             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5240           enddo
5241         endif
5242       enddo
5243       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5244
5245       return
5246       end subroutine edis
5247 !-----------------------------------------------------------------------------
5248       subroutine ssbond_ene(i,j,eij)
5249 !
5250 ! Calculate the distance and angle dependent SS-bond potential energy
5251 ! using a free-energy function derived based on RHF/6-31G** ab initio
5252 ! calculations of diethyl disulfide.
5253 !
5254 ! A. Liwo and U. Kozlowska, 11/24/03
5255 !
5256 !      implicit real*8 (a-h,o-z)
5257 !      include 'DIMENSIONS'
5258 !      include 'COMMON.SBRIDGE'
5259 !      include 'COMMON.CHAIN'
5260 !      include 'COMMON.DERIV'
5261 !      include 'COMMON.LOCAL'
5262 !      include 'COMMON.INTERACT'
5263 !      include 'COMMON.VAR'
5264 !      include 'COMMON.IOUNITS'
5265       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5266 !el local variables
5267       integer :: i,j,itypi,itypj,k
5268       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5269                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5270                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5271                    cosphi,ggk
5272
5273       itypi=iabs(itype(i,1))
5274       xi=c(1,nres+i)
5275       yi=c(2,nres+i)
5276       zi=c(3,nres+i)
5277       dxi=dc_norm(1,nres+i)
5278       dyi=dc_norm(2,nres+i)
5279       dzi=dc_norm(3,nres+i)
5280 !      dsci_inv=dsc_inv(itypi)
5281       dsci_inv=vbld_inv(nres+i)
5282       itypj=iabs(itype(j,1))
5283 !      dscj_inv=dsc_inv(itypj)
5284       dscj_inv=vbld_inv(nres+j)
5285       xj=c(1,nres+j)-xi
5286       yj=c(2,nres+j)-yi
5287       zj=c(3,nres+j)-zi
5288       dxj=dc_norm(1,nres+j)
5289       dyj=dc_norm(2,nres+j)
5290       dzj=dc_norm(3,nres+j)
5291       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5292       rij=dsqrt(rrij)
5293       erij(1)=xj*rij
5294       erij(2)=yj*rij
5295       erij(3)=zj*rij
5296       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5297       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5298       om12=dxi*dxj+dyi*dyj+dzi*dzj
5299       do k=1,3
5300         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5301         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5302       enddo
5303       rij=1.0d0/rij
5304       deltad=rij-d0cm
5305       deltat1=1.0d0-om1
5306       deltat2=1.0d0+om2
5307       deltat12=om2-om1+2.0d0
5308       cosphi=om12-om1*om2
5309       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5310         +akct*deltad*deltat12 &
5311         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5312 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5313 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5314 !     &  " deltat12",deltat12," eij",eij
5315       ed=2*akcm*deltad+akct*deltat12
5316       pom1=akct*deltad
5317       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5318       eom1=-2*akth*deltat1-pom1-om2*pom2
5319       eom2= 2*akth*deltat2+pom1-om1*pom2
5320       eom12=pom2
5321       do k=1,3
5322         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5323         ghpbx(k,i)=ghpbx(k,i)-ggk &
5324                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5325                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5326         ghpbx(k,j)=ghpbx(k,j)+ggk &
5327                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5328                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5329         ghpbc(k,i)=ghpbc(k,i)-ggk
5330         ghpbc(k,j)=ghpbc(k,j)+ggk
5331       enddo
5332 !
5333 ! Calculate the components of the gradient in DC and X
5334 !
5335 !grad      do k=i,j-1
5336 !grad        do l=1,3
5337 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5338 !grad        enddo
5339 !grad      enddo
5340       return
5341       end subroutine ssbond_ene
5342 !-----------------------------------------------------------------------------
5343       subroutine ebond(estr)
5344 !
5345 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5346 !
5347 !      implicit real*8 (a-h,o-z)
5348 !      include 'DIMENSIONS'
5349 !      include 'COMMON.LOCAL'
5350 !      include 'COMMON.GEO'
5351 !      include 'COMMON.INTERACT'
5352 !      include 'COMMON.DERIV'
5353 !      include 'COMMON.VAR'
5354 !      include 'COMMON.CHAIN'
5355 !      include 'COMMON.IOUNITS'
5356 !      include 'COMMON.NAMES'
5357 !      include 'COMMON.FFIELD'
5358 !      include 'COMMON.CONTROL'
5359 !      include 'COMMON.SETUP'
5360       real(kind=8),dimension(3) :: u,ud
5361 !el local variables
5362       integer :: i,j,iti,nbi,k
5363       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5364                    uprod1,uprod2
5365
5366       estr=0.0d0
5367       estr1=0.0d0
5368 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5369 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5370
5371       do i=ibondp_start,ibondp_end
5372         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5373         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5374 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5375 !C          do j=1,3
5376 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5377 !C            *dc(j,i-1)/vbld(i)
5378 !C          enddo
5379 !C          if (energy_dec) write(iout,*) &
5380 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5381         diff = vbld(i)-vbldpDUM
5382         else
5383         diff = vbld(i)-vbldp0
5384         endif
5385         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5386            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5387         estr=estr+diff*diff
5388         do j=1,3
5389           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5390         enddo
5391 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5392 !        endif
5393       enddo
5394       estr=0.5d0*AKP*estr+estr1
5395 !      print *,"estr_bb",estr,AKP
5396 !
5397 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5398 !
5399       do i=ibond_start,ibond_end
5400         iti=iabs(itype(i,1))
5401         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5402         if (iti.ne.10 .and. iti.ne.ntyp1) then
5403           nbi=nbondterm(iti)
5404           if (nbi.eq.1) then
5405             diff=vbld(i+nres)-vbldsc0(1,iti)
5406             if (energy_dec) write (iout,*) &
5407             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5408             AKSC(1,iti),AKSC(1,iti)*diff*diff
5409             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5410 !            print *,"estr_sc",estr
5411             do j=1,3
5412               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5413             enddo
5414           else
5415             do j=1,nbi
5416               diff=vbld(i+nres)-vbldsc0(j,iti)
5417               ud(j)=aksc(j,iti)*diff
5418               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5419             enddo
5420             uprod=u(1)
5421             do j=2,nbi
5422               uprod=uprod*u(j)
5423             enddo
5424             usum=0.0d0
5425             usumsqder=0.0d0
5426             do j=1,nbi
5427               uprod1=1.0d0
5428               uprod2=1.0d0
5429               do k=1,nbi
5430                 if (k.ne.j) then
5431                   uprod1=uprod1*u(k)
5432                   uprod2=uprod2*u(k)*u(k)
5433                 endif
5434               enddo
5435               usum=usum+uprod1
5436               usumsqder=usumsqder+ud(j)*uprod2
5437             enddo
5438             estr=estr+uprod/usum
5439 !            print *,"estr_sc",estr,i
5440
5441              if (energy_dec) write (iout,*) &
5442             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5443             AKSC(1,iti),uprod/usum
5444             do j=1,3
5445              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5446             enddo
5447           endif
5448         endif
5449       enddo
5450       return
5451       end subroutine ebond
5452 #ifdef CRYST_THETA
5453 !-----------------------------------------------------------------------------
5454       subroutine ebend(etheta)
5455 !
5456 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5457 ! angles gamma and its derivatives in consecutive thetas and gammas.
5458 !
5459       use comm_calcthet
5460 !      implicit real*8 (a-h,o-z)
5461 !      include 'DIMENSIONS'
5462 !      include 'COMMON.LOCAL'
5463 !      include 'COMMON.GEO'
5464 !      include 'COMMON.INTERACT'
5465 !      include 'COMMON.DERIV'
5466 !      include 'COMMON.VAR'
5467 !      include 'COMMON.CHAIN'
5468 !      include 'COMMON.IOUNITS'
5469 !      include 'COMMON.NAMES'
5470 !      include 'COMMON.FFIELD'
5471 !      include 'COMMON.CONTROL'
5472 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5473 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5474 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5475 !el      integer :: it
5476 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5477 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5478 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5479 !el local variables
5480       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5481        ichir21,ichir22
5482       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5483        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5484        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5485       real(kind=8),dimension(2) :: y,z
5486
5487       delta=0.02d0*pi
5488 !      time11=dexp(-2*time)
5489 !      time12=1.0d0
5490       etheta=0.0D0
5491 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5492       do i=ithet_start,ithet_end
5493         if (itype(i-1,1).eq.ntyp1) cycle
5494 ! Zero the energy function and its derivative at 0 or pi.
5495         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5496         it=itype(i-1,1)
5497         ichir1=isign(1,itype(i-2,1))
5498         ichir2=isign(1,itype(i,1))
5499          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5500          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5501          if (itype(i-1,1).eq.10) then
5502           itype1=isign(10,itype(i-2,1))
5503           ichir11=isign(1,itype(i-2,1))
5504           ichir12=isign(1,itype(i-2,1))
5505           itype2=isign(10,itype(i,1))
5506           ichir21=isign(1,itype(i,1))
5507           ichir22=isign(1,itype(i,1))
5508          endif
5509
5510         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5511 #ifdef OSF
5512           phii=phi(i)
5513           if (phii.ne.phii) phii=150.0
5514 #else
5515           phii=phi(i)
5516 #endif
5517           y(1)=dcos(phii)
5518           y(2)=dsin(phii)
5519         else
5520           y(1)=0.0D0
5521           y(2)=0.0D0
5522         endif
5523         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5524 #ifdef OSF
5525           phii1=phi(i+1)
5526           if (phii1.ne.phii1) phii1=150.0
5527           phii1=pinorm(phii1)
5528           z(1)=cos(phii1)
5529 #else
5530           phii1=phi(i+1)
5531           z(1)=dcos(phii1)
5532 #endif
5533           z(2)=dsin(phii1)
5534         else
5535           z(1)=0.0D0
5536           z(2)=0.0D0
5537         endif
5538 ! Calculate the "mean" value of theta from the part of the distribution
5539 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5540 ! In following comments this theta will be referred to as t_c.
5541         thet_pred_mean=0.0d0
5542         do k=1,2
5543             athetk=athet(k,it,ichir1,ichir2)
5544             bthetk=bthet(k,it,ichir1,ichir2)
5545           if (it.eq.10) then
5546              athetk=athet(k,itype1,ichir11,ichir12)
5547              bthetk=bthet(k,itype2,ichir21,ichir22)
5548           endif
5549          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5550         enddo
5551         dthett=thet_pred_mean*ssd
5552         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5553 ! Derivatives of the "mean" values in gamma1 and gamma2.
5554         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5555                +athet(2,it,ichir1,ichir2)*y(1))*ss
5556         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5557                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5558          if (it.eq.10) then
5559         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5560              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5561         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5562                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5563          endif
5564         if (theta(i).gt.pi-delta) then
5565           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5566                E_tc0)
5567           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5568           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5569           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5570               E_theta)
5571           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5572               E_tc)
5573         else if (theta(i).lt.delta) then
5574           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5575           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5576           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5577               E_theta)
5578           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5579           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5580               E_tc)
5581         else
5582           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5583               E_theta,E_tc)
5584         endif
5585         etheta=etheta+ethetai
5586         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5587             'ebend',i,ethetai
5588         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5589         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5590         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5591       enddo
5592 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5593
5594 ! Ufff.... We've done all this!!!
5595       return
5596       end subroutine ebend
5597 !-----------------------------------------------------------------------------
5598       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5599
5600       use comm_calcthet
5601 !      implicit real*8 (a-h,o-z)
5602 !      include 'DIMENSIONS'
5603 !      include 'COMMON.LOCAL'
5604 !      include 'COMMON.IOUNITS'
5605 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5606 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5607 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5608       integer :: i,j,k
5609       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5610 !el      integer :: it
5611 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5612 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5613 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5614 !el local variables
5615       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5616        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5617
5618 ! Calculate the contributions to both Gaussian lobes.
5619 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5620 ! The "polynomial part" of the "standard deviation" of this part of
5621 ! the distribution.
5622         sig=polthet(3,it)
5623         do j=2,0,-1
5624           sig=sig*thet_pred_mean+polthet(j,it)
5625         enddo
5626 ! Derivative of the "interior part" of the "standard deviation of the"
5627 ! gamma-dependent Gaussian lobe in t_c.
5628         sigtc=3*polthet(3,it)
5629         do j=2,1,-1
5630           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5631         enddo
5632         sigtc=sig*sigtc
5633 ! Set the parameters of both Gaussian lobes of the distribution.
5634 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5635         fac=sig*sig+sigc0(it)
5636         sigcsq=fac+fac
5637         sigc=1.0D0/sigcsq
5638 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5639         sigsqtc=-4.0D0*sigcsq*sigtc
5640 !       print *,i,sig,sigtc,sigsqtc
5641 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5642         sigtc=-sigtc/(fac*fac)
5643 ! Following variable is sigma(t_c)**(-2)
5644         sigcsq=sigcsq*sigcsq
5645         sig0i=sig0(it)
5646         sig0inv=1.0D0/sig0i**2
5647         delthec=thetai-thet_pred_mean
5648         delthe0=thetai-theta0i
5649         term1=-0.5D0*sigcsq*delthec*delthec
5650         term2=-0.5D0*sig0inv*delthe0*delthe0
5651 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5652 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5653 ! to the energy (this being the log of the distribution) at the end of energy
5654 ! term evaluation for this virtual-bond angle.
5655         if (term1.gt.term2) then
5656           termm=term1
5657           term2=dexp(term2-termm)
5658           term1=1.0d0
5659         else
5660           termm=term2
5661           term1=dexp(term1-termm)
5662           term2=1.0d0
5663         endif
5664 ! The ratio between the gamma-independent and gamma-dependent lobes of
5665 ! the distribution is a Gaussian function of thet_pred_mean too.
5666         diffak=gthet(2,it)-thet_pred_mean
5667         ratak=diffak/gthet(3,it)**2
5668         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5669 ! Let's differentiate it in thet_pred_mean NOW.
5670         aktc=ak*ratak
5671 ! Now put together the distribution terms to make complete distribution.
5672         termexp=term1+ak*term2
5673         termpre=sigc+ak*sig0i
5674 ! Contribution of the bending energy from this theta is just the -log of
5675 ! the sum of the contributions from the two lobes and the pre-exponential
5676 ! factor. Simple enough, isn't it?
5677         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5678 ! NOW the derivatives!!!
5679 ! 6/6/97 Take into account the deformation.
5680         E_theta=(delthec*sigcsq*term1 &
5681              +ak*delthe0*sig0inv*term2)/termexp
5682         E_tc=((sigtc+aktc*sig0i)/termpre &
5683             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5684              aktc*term2)/termexp)
5685       return
5686       end subroutine theteng
5687 #else
5688 !-----------------------------------------------------------------------------
5689       subroutine ebend(etheta,ethetacnstr)
5690 !
5691 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5692 ! angles gamma and its derivatives in consecutive thetas and gammas.
5693 ! ab initio-derived potentials from
5694 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5695 !
5696 !      implicit real*8 (a-h,o-z)
5697 !      include 'DIMENSIONS'
5698 !      include 'COMMON.LOCAL'
5699 !      include 'COMMON.GEO'
5700 !      include 'COMMON.INTERACT'
5701 !      include 'COMMON.DERIV'
5702 !      include 'COMMON.VAR'
5703 !      include 'COMMON.CHAIN'
5704 !      include 'COMMON.IOUNITS'
5705 !      include 'COMMON.NAMES'
5706 !      include 'COMMON.FFIELD'
5707 !      include 'COMMON.CONTROL'
5708       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5709       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5710       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5711       logical :: lprn=.false., lprn1=.false.
5712 !el local variables
5713       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5714       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5715       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5716 ! local variables for constrains
5717       real(kind=8) :: difi,thetiii
5718        integer itheta
5719
5720       etheta=0.0D0
5721       do i=ithet_start,ithet_end
5722         if (itype(i-1,1).eq.ntyp1) cycle
5723         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5724         if (iabs(itype(i+1,1)).eq.20) iblock=2
5725         if (iabs(itype(i+1,1)).ne.20) iblock=1
5726         dethetai=0.0d0
5727         dephii=0.0d0
5728         dephii1=0.0d0
5729         theti2=0.5d0*theta(i)
5730         ityp2=ithetyp((itype(i-1,1)))
5731         do k=1,nntheterm
5732           coskt(k)=dcos(k*theti2)
5733           sinkt(k)=dsin(k*theti2)
5734         enddo
5735         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5736 #ifdef OSF
5737           phii=phi(i)
5738           if (phii.ne.phii) phii=150.0
5739 #else
5740           phii=phi(i)
5741 #endif
5742           ityp1=ithetyp((itype(i-2,1)))
5743 ! propagation of chirality for glycine type
5744           do k=1,nsingle
5745             cosph1(k)=dcos(k*phii)
5746             sinph1(k)=dsin(k*phii)
5747           enddo
5748         else
5749           phii=0.0d0
5750           ityp1=ithetyp(itype(i-2,1))
5751           do k=1,nsingle
5752             cosph1(k)=0.0d0
5753             sinph1(k)=0.0d0
5754           enddo
5755         endif
5756         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5757 #ifdef OSF
5758           phii1=phi(i+1)
5759           if (phii1.ne.phii1) phii1=150.0
5760           phii1=pinorm(phii1)
5761 #else
5762           phii1=phi(i+1)
5763 #endif
5764           ityp3=ithetyp((itype(i,1)))
5765           do k=1,nsingle
5766             cosph2(k)=dcos(k*phii1)
5767             sinph2(k)=dsin(k*phii1)
5768           enddo
5769         else
5770           phii1=0.0d0
5771           ityp3=ithetyp(itype(i,1))
5772           do k=1,nsingle
5773             cosph2(k)=0.0d0
5774             sinph2(k)=0.0d0
5775           enddo
5776         endif
5777         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5778         do k=1,ndouble
5779           do l=1,k-1
5780             ccl=cosph1(l)*cosph2(k-l)
5781             ssl=sinph1(l)*sinph2(k-l)
5782             scl=sinph1(l)*cosph2(k-l)
5783             csl=cosph1(l)*sinph2(k-l)
5784             cosph1ph2(l,k)=ccl-ssl
5785             cosph1ph2(k,l)=ccl+ssl
5786             sinph1ph2(l,k)=scl+csl
5787             sinph1ph2(k,l)=scl-csl
5788           enddo
5789         enddo
5790         if (lprn) then
5791         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5792           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5793         write (iout,*) "coskt and sinkt"
5794         do k=1,nntheterm
5795           write (iout,*) k,coskt(k),sinkt(k)
5796         enddo
5797         endif
5798         do k=1,ntheterm
5799           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5800           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5801             *coskt(k)
5802           if (lprn) &
5803           write (iout,*) "k",k,&
5804            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5805            " ethetai",ethetai
5806         enddo
5807         if (lprn) then
5808         write (iout,*) "cosph and sinph"
5809         do k=1,nsingle
5810           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5811         enddo
5812         write (iout,*) "cosph1ph2 and sinph2ph2"
5813         do k=2,ndouble
5814           do l=1,k-1
5815             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5816                sinph1ph2(l,k),sinph1ph2(k,l)
5817           enddo
5818         enddo
5819         write(iout,*) "ethetai",ethetai
5820         endif
5821         do m=1,ntheterm2
5822           do k=1,nsingle
5823             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5824                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5825                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5826                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5827             ethetai=ethetai+sinkt(m)*aux
5828             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5829             dephii=dephii+k*sinkt(m)* &
5830                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5831                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5832             dephii1=dephii1+k*sinkt(m)* &
5833                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5834                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5835             if (lprn) &
5836             write (iout,*) "m",m," k",k," bbthet", &
5837                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5838                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5839                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5840                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5841           enddo
5842         enddo
5843         if (lprn) &
5844         write(iout,*) "ethetai",ethetai
5845         do m=1,ntheterm3
5846           do k=2,ndouble
5847             do l=1,k-1
5848               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5849                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5850                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5851                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5852               ethetai=ethetai+sinkt(m)*aux
5853               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5854               dephii=dephii+l*sinkt(m)* &
5855                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5856                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5857                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5858                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5859               dephii1=dephii1+(k-l)*sinkt(m)* &
5860                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5861                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5862                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5863                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5864               if (lprn) then
5865               write (iout,*) "m",m," k",k," l",l," ffthet",&
5866                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5867                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5868                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5869                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5870                   " ethetai",ethetai
5871               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5872                   cosph1ph2(k,l)*sinkt(m),&
5873                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5874               endif
5875             enddo
5876           enddo
5877         enddo
5878 10      continue
5879 !        lprn1=.true.
5880         if (lprn1) &
5881           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5882          i,theta(i)*rad2deg,phii*rad2deg,&
5883          phii1*rad2deg,ethetai
5884 !        lprn1=.false.
5885         etheta=etheta+ethetai
5886         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5887                                     'ebend',i,ethetai
5888         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5889         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5890         gloc(nphi+i-2,icg)=wang*dethetai
5891       enddo
5892 !-----------thete constrains
5893 !      if (tor_mode.ne.2) then
5894       ethetacnstr=0.0d0
5895 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5896       do i=ithetaconstr_start,ithetaconstr_end
5897         itheta=itheta_constr(i)
5898         thetiii=theta(itheta)
5899         difi=pinorm(thetiii-theta_constr0(i))
5900         if (difi.gt.theta_drange(i)) then
5901           difi=difi-theta_drange(i)
5902           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5903           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5904          +for_thet_constr(i)*difi**3
5905         else if (difi.lt.-drange(i)) then
5906           difi=difi+drange(i)
5907           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5908           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5909          +for_thet_constr(i)*difi**3
5910         else
5911           difi=0.0
5912         endif
5913        if (energy_dec) then
5914         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5915          i,itheta,rad2deg*thetiii, &
5916          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5917          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5918          gloc(itheta+nphi-2,icg)
5919         endif
5920       enddo
5921 !      endif
5922
5923       return
5924       end subroutine ebend
5925 #endif
5926 #ifdef CRYST_SC
5927 !-----------------------------------------------------------------------------
5928       subroutine esc(escloc)
5929 ! Calculate the local energy of a side chain and its derivatives in the
5930 ! corresponding virtual-bond valence angles THETA and the spherical angles
5931 ! ALPHA and OMEGA.
5932 !
5933       use comm_sccalc
5934 !      implicit real*8 (a-h,o-z)
5935 !      include 'DIMENSIONS'
5936 !      include 'COMMON.GEO'
5937 !      include 'COMMON.LOCAL'
5938 !      include 'COMMON.VAR'
5939 !      include 'COMMON.INTERACT'
5940 !      include 'COMMON.DERIV'
5941 !      include 'COMMON.CHAIN'
5942 !      include 'COMMON.IOUNITS'
5943 !      include 'COMMON.NAMES'
5944 !      include 'COMMON.FFIELD'
5945 !      include 'COMMON.CONTROL'
5946       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5947          ddersc0,ddummy,xtemp,temp
5948 !el      real(kind=8) :: time11,time12,time112,theti
5949       real(kind=8) :: escloc,delta
5950 !el      integer :: it,nlobit
5951 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5952 !el local variables
5953       integer :: i,k
5954       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5955        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5956       delta=0.02d0*pi
5957       escloc=0.0D0
5958 !     write (iout,'(a)') 'ESC'
5959       do i=loc_start,loc_end
5960         it=itype(i,1)
5961         if (it.eq.ntyp1) cycle
5962         if (it.eq.10) goto 1
5963         nlobit=nlob(iabs(it))
5964 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5965 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5966         theti=theta(i+1)-pipol
5967         x(1)=dtan(theti)
5968         x(2)=alph(i)
5969         x(3)=omeg(i)
5970
5971         if (x(2).gt.pi-delta) then
5972           xtemp(1)=x(1)
5973           xtemp(2)=pi-delta
5974           xtemp(3)=x(3)
5975           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5976           xtemp(2)=pi
5977           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5978           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5979               escloci,dersc(2))
5980           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5981               ddersc0(1),dersc(1))
5982           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5983               ddersc0(3),dersc(3))
5984           xtemp(2)=pi-delta
5985           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5986           xtemp(2)=pi
5987           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5988           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5989                   dersc0(2),esclocbi,dersc02)
5990           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5991                   dersc12,dersc01)
5992           call splinthet(x(2),0.5d0*delta,ss,ssd)
5993           dersc0(1)=dersc01
5994           dersc0(2)=dersc02
5995           dersc0(3)=0.0d0
5996           do k=1,3
5997             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5998           enddo
5999           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6000 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6001 !    &             esclocbi,ss,ssd
6002           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6003 !         escloci=esclocbi
6004 !         write (iout,*) escloci
6005         else if (x(2).lt.delta) then
6006           xtemp(1)=x(1)
6007           xtemp(2)=delta
6008           xtemp(3)=x(3)
6009           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6010           xtemp(2)=0.0d0
6011           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6012           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6013               escloci,dersc(2))
6014           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6015               ddersc0(1),dersc(1))
6016           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6017               ddersc0(3),dersc(3))
6018           xtemp(2)=delta
6019           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6020           xtemp(2)=0.0d0
6021           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6022           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6023                   dersc0(2),esclocbi,dersc02)
6024           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6025                   dersc12,dersc01)
6026           dersc0(1)=dersc01
6027           dersc0(2)=dersc02
6028           dersc0(3)=0.0d0
6029           call splinthet(x(2),0.5d0*delta,ss,ssd)
6030           do k=1,3
6031             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6032           enddo
6033           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6034 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6035 !    &             esclocbi,ss,ssd
6036           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6037 !         write (iout,*) escloci
6038         else
6039           call enesc(x,escloci,dersc,ddummy,.false.)
6040         endif
6041
6042         escloc=escloc+escloci
6043         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6044            'escloc',i,escloci
6045 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6046
6047         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6048          wscloc*dersc(1)
6049         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6050         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6051     1   continue
6052       enddo
6053       return
6054       end subroutine esc
6055 !-----------------------------------------------------------------------------
6056       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6057
6058       use comm_sccalc
6059 !      implicit real*8 (a-h,o-z)
6060 !      include 'DIMENSIONS'
6061 !      include 'COMMON.GEO'
6062 !      include 'COMMON.LOCAL'
6063 !      include 'COMMON.IOUNITS'
6064 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6065       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6066       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6067       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6068       real(kind=8) :: escloci
6069       logical :: mixed
6070 !el local variables
6071       integer :: j,iii,l,k !el,it,nlobit
6072       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6073 !el       time11,time12,time112
6074 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6075         escloc_i=0.0D0
6076         do j=1,3
6077           dersc(j)=0.0D0
6078           if (mixed) ddersc(j)=0.0d0
6079         enddo
6080         x3=x(3)
6081
6082 ! Because of periodicity of the dependence of the SC energy in omega we have
6083 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6084 ! To avoid underflows, first compute & store the exponents.
6085
6086         do iii=-1,1
6087
6088           x(3)=x3+iii*dwapi
6089
6090           do j=1,nlobit
6091             do k=1,3
6092               z(k)=x(k)-censc(k,j,it)
6093             enddo
6094             do k=1,3
6095               Axk=0.0D0
6096               do l=1,3
6097                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6098               enddo
6099               Ax(k,j,iii)=Axk
6100             enddo
6101             expfac=0.0D0
6102             do k=1,3
6103               expfac=expfac+Ax(k,j,iii)*z(k)
6104             enddo
6105             contr(j,iii)=expfac
6106           enddo ! j
6107
6108         enddo ! iii
6109
6110         x(3)=x3
6111 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6112 ! subsequent NaNs and INFs in energy calculation.
6113 ! Find the largest exponent
6114         emin=contr(1,-1)
6115         do iii=-1,1
6116           do j=1,nlobit
6117             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6118           enddo
6119         enddo
6120         emin=0.5D0*emin
6121 !d      print *,'it=',it,' emin=',emin
6122
6123 ! Compute the contribution to SC energy and derivatives
6124         do iii=-1,1
6125
6126           do j=1,nlobit
6127 #ifdef OSF
6128             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6129             if(adexp.ne.adexp) adexp=1.0
6130             expfac=dexp(adexp)
6131 #else
6132             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6133 #endif
6134 !d          print *,'j=',j,' expfac=',expfac
6135             escloc_i=escloc_i+expfac
6136             do k=1,3
6137               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6138             enddo
6139             if (mixed) then
6140               do k=1,3,2
6141                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6142                   +gaussc(k,2,j,it))*expfac
6143               enddo
6144             endif
6145           enddo
6146
6147         enddo ! iii
6148
6149         dersc(1)=dersc(1)/cos(theti)**2
6150         ddersc(1)=ddersc(1)/cos(theti)**2
6151         ddersc(3)=ddersc(3)
6152
6153         escloci=-(dlog(escloc_i)-emin)
6154         do j=1,3
6155           dersc(j)=dersc(j)/escloc_i
6156         enddo
6157         if (mixed) then
6158           do j=1,3,2
6159             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6160           enddo
6161         endif
6162       return
6163       end subroutine enesc
6164 !-----------------------------------------------------------------------------
6165       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6166
6167       use comm_sccalc
6168 !      implicit real*8 (a-h,o-z)
6169 !      include 'DIMENSIONS'
6170 !      include 'COMMON.GEO'
6171 !      include 'COMMON.LOCAL'
6172 !      include 'COMMON.IOUNITS'
6173 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6174       real(kind=8),dimension(3) :: x,z,dersc
6175       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6176       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6177       real(kind=8) :: escloci,dersc12,emin
6178       logical :: mixed
6179 !el local varables
6180       integer :: j,k,l !el,it,nlobit
6181       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6182
6183       escloc_i=0.0D0
6184
6185       do j=1,3
6186         dersc(j)=0.0D0
6187       enddo
6188
6189       do j=1,nlobit
6190         do k=1,2
6191           z(k)=x(k)-censc(k,j,it)
6192         enddo
6193         z(3)=dwapi
6194         do k=1,3
6195           Axk=0.0D0
6196           do l=1,3
6197             Axk=Axk+gaussc(l,k,j,it)*z(l)
6198           enddo
6199           Ax(k,j)=Axk
6200         enddo
6201         expfac=0.0D0
6202         do k=1,3
6203           expfac=expfac+Ax(k,j)*z(k)
6204         enddo
6205         contr(j)=expfac
6206       enddo ! j
6207
6208 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6209 ! subsequent NaNs and INFs in energy calculation.
6210 ! Find the largest exponent
6211       emin=contr(1)
6212       do j=1,nlobit
6213         if (emin.gt.contr(j)) emin=contr(j)
6214       enddo
6215       emin=0.5D0*emin
6216
6217 ! Compute the contribution to SC energy and derivatives
6218
6219       dersc12=0.0d0
6220       do j=1,nlobit
6221         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6222         escloc_i=escloc_i+expfac
6223         do k=1,2
6224           dersc(k)=dersc(k)+Ax(k,j)*expfac
6225         enddo
6226         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6227                   +gaussc(1,2,j,it))*expfac
6228         dersc(3)=0.0d0
6229       enddo
6230
6231       dersc(1)=dersc(1)/cos(theti)**2
6232       dersc12=dersc12/cos(theti)**2
6233       escloci=-(dlog(escloc_i)-emin)
6234       do j=1,2
6235         dersc(j)=dersc(j)/escloc_i
6236       enddo
6237       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6238       return
6239       end subroutine enesc_bound
6240 #else
6241 !-----------------------------------------------------------------------------
6242       subroutine esc(escloc)
6243 ! Calculate the local energy of a side chain and its derivatives in the
6244 ! corresponding virtual-bond valence angles THETA and the spherical angles
6245 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6246 ! added by Urszula Kozlowska. 07/11/2007
6247 !
6248       use comm_sccalc
6249 !      implicit real*8 (a-h,o-z)
6250 !      include 'DIMENSIONS'
6251 !      include 'COMMON.GEO'
6252 !      include 'COMMON.LOCAL'
6253 !      include 'COMMON.VAR'
6254 !      include 'COMMON.SCROT'
6255 !      include 'COMMON.INTERACT'
6256 !      include 'COMMON.DERIV'
6257 !      include 'COMMON.CHAIN'
6258 !      include 'COMMON.IOUNITS'
6259 !      include 'COMMON.NAMES'
6260 !      include 'COMMON.FFIELD'
6261 !      include 'COMMON.CONTROL'
6262 !      include 'COMMON.VECTORS'
6263       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6264       real(kind=8),dimension(65) :: x
6265       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6266          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6267       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6268       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6269          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6270 !el local variables
6271       integer :: i,j,k !el,it,nlobit
6272       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6273 !el      real(kind=8) :: time11,time12,time112,theti
6274 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6275       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6276                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6277                    sumene1x,sumene2x,sumene3x,sumene4x,&
6278                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6279                    cosfac2xx,sinfac2yy
6280 #ifdef DEBUG
6281       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6282                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6283                    de_dt_num
6284 #endif
6285 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6286
6287       delta=0.02d0*pi
6288       escloc=0.0D0
6289       do i=loc_start,loc_end
6290         if (itype(i,1).eq.ntyp1) cycle
6291         costtab(i+1) =dcos(theta(i+1))
6292         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6293         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6294         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6295         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6296         cosfac=dsqrt(cosfac2)
6297         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6298         sinfac=dsqrt(sinfac2)
6299         it=iabs(itype(i,1))
6300         if (it.eq.10) goto 1
6301 !
6302 !  Compute the axes of tghe local cartesian coordinates system; store in
6303 !   x_prime, y_prime and z_prime
6304 !
6305         do j=1,3
6306           x_prime(j) = 0.00
6307           y_prime(j) = 0.00
6308           z_prime(j) = 0.00
6309         enddo
6310 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6311 !     &   dc_norm(3,i+nres)
6312         do j = 1,3
6313           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6314           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6315         enddo
6316         do j = 1,3
6317           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6318         enddo
6319 !       write (2,*) "i",i
6320 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6321 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6322 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6323 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6324 !      & " xy",scalar(x_prime(1),y_prime(1)),
6325 !      & " xz",scalar(x_prime(1),z_prime(1)),
6326 !      & " yy",scalar(y_prime(1),y_prime(1)),
6327 !      & " yz",scalar(y_prime(1),z_prime(1)),
6328 !      & " zz",scalar(z_prime(1),z_prime(1))
6329 !
6330 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6331 ! to local coordinate system. Store in xx, yy, zz.
6332 !
6333         xx=0.0d0
6334         yy=0.0d0
6335         zz=0.0d0
6336         do j = 1,3
6337           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6338           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6339           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6340         enddo
6341
6342         xxtab(i)=xx
6343         yytab(i)=yy
6344         zztab(i)=zz
6345 !
6346 ! Compute the energy of the ith side cbain
6347 !
6348 !        write (2,*) "xx",xx," yy",yy," zz",zz
6349         it=iabs(itype(i,1))
6350         do j = 1,65
6351           x(j) = sc_parmin(j,it)
6352         enddo
6353 #ifdef CHECK_COORD
6354 !c diagnostics - remove later
6355         xx1 = dcos(alph(2))
6356         yy1 = dsin(alph(2))*dcos(omeg(2))
6357         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6358         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6359           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6360           xx1,yy1,zz1
6361 !,"  --- ", xx_w,yy_w,zz_w
6362 ! end diagnostics
6363 #endif
6364         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6365          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6366          + x(10)*yy*zz
6367         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6368          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6369          + x(20)*yy*zz
6370         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6371          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6372          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6373          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6374          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6375          +x(40)*xx*yy*zz
6376         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6377          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6378          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6379          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6380          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6381          +x(60)*xx*yy*zz
6382         dsc_i   = 0.743d0+x(61)
6383         dp2_i   = 1.9d0+x(62)
6384         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6385                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6386         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6387                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6388         s1=(1+x(63))/(0.1d0 + dscp1)
6389         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6390         s2=(1+x(65))/(0.1d0 + dscp2)
6391         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6392         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6393       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6394 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6395 !     &   sumene4,
6396 !     &   dscp1,dscp2,sumene
6397 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6398         escloc = escloc + sumene
6399 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6400 !     & ,zz,xx,yy
6401 !#define DEBUG
6402 #ifdef DEBUG
6403 !
6404 ! This section to check the numerical derivatives of the energy of ith side
6405 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6406 ! #define DEBUG in the code to turn it on.
6407 !
6408         write (2,*) "sumene               =",sumene
6409         aincr=1.0d-7
6410         xxsave=xx
6411         xx=xx+aincr
6412         write (2,*) xx,yy,zz
6413         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6414         de_dxx_num=(sumenep-sumene)/aincr
6415         xx=xxsave
6416         write (2,*) "xx+ sumene from enesc=",sumenep
6417         yysave=yy
6418         yy=yy+aincr
6419         write (2,*) xx,yy,zz
6420         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6421         de_dyy_num=(sumenep-sumene)/aincr
6422         yy=yysave
6423         write (2,*) "yy+ sumene from enesc=",sumenep
6424         zzsave=zz
6425         zz=zz+aincr
6426         write (2,*) xx,yy,zz
6427         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6428         de_dzz_num=(sumenep-sumene)/aincr
6429         zz=zzsave
6430         write (2,*) "zz+ sumene from enesc=",sumenep
6431         costsave=cost2tab(i+1)
6432         sintsave=sint2tab(i+1)
6433         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6434         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6435         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6436         de_dt_num=(sumenep-sumene)/aincr
6437         write (2,*) " t+ sumene from enesc=",sumenep
6438         cost2tab(i+1)=costsave
6439         sint2tab(i+1)=sintsave
6440 ! End of diagnostics section.
6441 #endif
6442 !
6443 ! Compute the gradient of esc
6444 !
6445 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6446         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6447         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6448         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6449         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6450         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6451         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6452         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6453         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6454         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6455            *(pom_s1/dscp1+pom_s16*dscp1**4)
6456         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6457            *(pom_s2/dscp2+pom_s26*dscp2**4)
6458         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6459         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6460         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6461         +x(40)*yy*zz
6462         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6463         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6464         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6465         +x(60)*yy*zz
6466         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6467               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6468               +(pom1+pom2)*pom_dx
6469 #ifdef DEBUG
6470         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6471 #endif
6472 !
6473         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6474         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6475         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6476         +x(40)*xx*zz
6477         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6478         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6479         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6480         +x(59)*zz**2 +x(60)*xx*zz
6481         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6482               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6483               +(pom1-pom2)*pom_dy
6484 #ifdef DEBUG
6485         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6486 #endif
6487 !
6488         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6489         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6490         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6491         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6492         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6493         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6494         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6495         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6496 #ifdef DEBUG
6497         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6498 #endif
6499 !
6500         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6501         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6502         +pom1*pom_dt1+pom2*pom_dt2
6503 #ifdef DEBUG
6504         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6505 #endif
6506 !
6507 !
6508        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6509        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6510        cosfac2xx=cosfac2*xx
6511        sinfac2yy=sinfac2*yy
6512        do k = 1,3
6513          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6514             vbld_inv(i+1)
6515          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6516             vbld_inv(i)
6517          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6518          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6519 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6520 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6521 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6522 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6523          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6524          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6525          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6526          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6527          dZZ_Ci1(k)=0.0d0
6528          dZZ_Ci(k)=0.0d0
6529          do j=1,3
6530            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6531            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6532            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6533            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6534          enddo
6535
6536          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6537          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6538          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6539          (z_prime(k)-zz*dC_norm(k,i+nres))
6540 !
6541          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6542          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6543        enddo
6544
6545        do k=1,3
6546          dXX_Ctab(k,i)=dXX_Ci(k)
6547          dXX_C1tab(k,i)=dXX_Ci1(k)
6548          dYY_Ctab(k,i)=dYY_Ci(k)
6549          dYY_C1tab(k,i)=dYY_Ci1(k)
6550          dZZ_Ctab(k,i)=dZZ_Ci(k)
6551          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6552          dXX_XYZtab(k,i)=dXX_XYZ(k)
6553          dYY_XYZtab(k,i)=dYY_XYZ(k)
6554          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6555        enddo
6556
6557        do k = 1,3
6558 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6559 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6560 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6561 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6562 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6563 !     &    dt_dci(k)
6564 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6565 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6566          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6567           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6568          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6569           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6570          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6571           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6572        enddo
6573 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6574 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6575
6576 ! to check gradient call subroutine check_grad
6577
6578     1 continue
6579       enddo
6580       return
6581       end subroutine esc
6582 !-----------------------------------------------------------------------------
6583       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6584 !      implicit none
6585       real(kind=8),dimension(65) :: x
6586       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6587         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6588
6589       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6590         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6591         + x(10)*yy*zz
6592       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6593         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6594         + x(20)*yy*zz
6595       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6596         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6597         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6598         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6599         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6600         +x(40)*xx*yy*zz
6601       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6602         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6603         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6604         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6605         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6606         +x(60)*xx*yy*zz
6607       dsc_i   = 0.743d0+x(61)
6608       dp2_i   = 1.9d0+x(62)
6609       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6610                 *(xx*cost2+yy*sint2))
6611       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6612                 *(xx*cost2-yy*sint2))
6613       s1=(1+x(63))/(0.1d0 + dscp1)
6614       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6615       s2=(1+x(65))/(0.1d0 + dscp2)
6616       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6617       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6618        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6619       enesc=sumene
6620       return
6621       end function enesc
6622 #endif
6623 !-----------------------------------------------------------------------------
6624       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6625 !
6626 ! This procedure calculates two-body contact function g(rij) and its derivative:
6627 !
6628 !           eps0ij                                     !       x < -1
6629 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6630 !            0                                         !       x > 1
6631 !
6632 ! where x=(rij-r0ij)/delta
6633 !
6634 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6635 !
6636 !      implicit none
6637       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6638       real(kind=8) :: x,x2,x4,delta
6639 !     delta=0.02D0*r0ij
6640 !      delta=0.2D0*r0ij
6641       x=(rij-r0ij)/delta
6642       if (x.lt.-1.0D0) then
6643         fcont=eps0ij
6644         fprimcont=0.0D0
6645       else if (x.le.1.0D0) then
6646         x2=x*x
6647         x4=x2*x2
6648         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6649         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6650       else
6651         fcont=0.0D0
6652         fprimcont=0.0D0
6653       endif
6654       return
6655       end subroutine gcont
6656 !-----------------------------------------------------------------------------
6657       subroutine splinthet(theti,delta,ss,ssder)
6658 !      implicit real*8 (a-h,o-z)
6659 !      include 'DIMENSIONS'
6660 !      include 'COMMON.VAR'
6661 !      include 'COMMON.GEO'
6662       real(kind=8) :: theti,delta,ss,ssder
6663       real(kind=8) :: thetup,thetlow
6664       thetup=pi-delta
6665       thetlow=delta
6666       if (theti.gt.pipol) then
6667         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6668       else
6669         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6670         ssder=-ssder
6671       endif
6672       return
6673       end subroutine splinthet
6674 !-----------------------------------------------------------------------------
6675       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6676 !      implicit none
6677       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6678       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6679       a1=fprim0*delta/(f1-f0)
6680       a2=3.0d0-2.0d0*a1
6681       a3=a1-2.0d0
6682       ksi=(x-x0)/delta
6683       ksi2=ksi*ksi
6684       ksi3=ksi2*ksi
6685       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6686       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6687       return
6688       end subroutine spline1
6689 !-----------------------------------------------------------------------------
6690       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6691 !      implicit none
6692       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6693       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6694       ksi=(x-x0)/delta
6695       ksi2=ksi*ksi
6696       ksi3=ksi2*ksi
6697       a1=fprim0x*delta
6698       a2=3*(f1x-f0x)-2*fprim0x*delta
6699       a3=fprim0x*delta-2*(f1x-f0x)
6700       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6701       return
6702       end subroutine spline2
6703 !-----------------------------------------------------------------------------
6704 #ifdef CRYST_TOR
6705 !-----------------------------------------------------------------------------
6706       subroutine etor(etors,edihcnstr)
6707 !      implicit real*8 (a-h,o-z)
6708 !      include 'DIMENSIONS'
6709 !      include 'COMMON.VAR'
6710 !      include 'COMMON.GEO'
6711 !      include 'COMMON.LOCAL'
6712 !      include 'COMMON.TORSION'
6713 !      include 'COMMON.INTERACT'
6714 !      include 'COMMON.DERIV'
6715 !      include 'COMMON.CHAIN'
6716 !      include 'COMMON.NAMES'
6717 !      include 'COMMON.IOUNITS'
6718 !      include 'COMMON.FFIELD'
6719 !      include 'COMMON.TORCNSTR'
6720 !      include 'COMMON.CONTROL'
6721       real(kind=8) :: etors,edihcnstr
6722       logical :: lprn
6723 !el local variables
6724       integer :: i,j,
6725       real(kind=8) :: phii,fac,etors_ii
6726
6727 ! Set lprn=.true. for debugging
6728       lprn=.false.
6729 !      lprn=.true.
6730       etors=0.0D0
6731       do i=iphi_start,iphi_end
6732       etors_ii=0.0D0
6733         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6734             .or. itype(i,1).eq.ntyp1) cycle
6735         itori=itortyp(itype(i-2,1))
6736         itori1=itortyp(itype(i-1,1))
6737         phii=phi(i)
6738         gloci=0.0D0
6739 ! Proline-Proline pair is a special case...
6740         if (itori.eq.3 .and. itori1.eq.3) then
6741           if (phii.gt.-dwapi3) then
6742             cosphi=dcos(3*phii)
6743             fac=1.0D0/(1.0D0-cosphi)
6744             etorsi=v1(1,3,3)*fac
6745             etorsi=etorsi+etorsi
6746             etors=etors+etorsi-v1(1,3,3)
6747             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6748             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6749           endif
6750           do j=1,3
6751             v1ij=v1(j+1,itori,itori1)
6752             v2ij=v2(j+1,itori,itori1)
6753             cosphi=dcos(j*phii)
6754             sinphi=dsin(j*phii)
6755             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6756             if (energy_dec) etors_ii=etors_ii+ &
6757                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6758             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6759           enddo
6760         else
6761           do j=1,nterm_old
6762             v1ij=v1(j,itori,itori1)
6763             v2ij=v2(j,itori,itori1)
6764             cosphi=dcos(j*phii)
6765             sinphi=dsin(j*phii)
6766             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6767             if (energy_dec) etors_ii=etors_ii+ &
6768                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6769             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6770           enddo
6771         endif
6772         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6773              'etor',i,etors_ii
6774         if (lprn) &
6775         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6776         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6777         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6778         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6779 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6780       enddo
6781 ! 6/20/98 - dihedral angle constraints
6782       edihcnstr=0.0d0
6783       do i=1,ndih_constr
6784         itori=idih_constr(i)
6785         phii=phi(itori)
6786         difi=phii-phi0(i)
6787         if (difi.gt.drange(i)) then
6788           difi=difi-drange(i)
6789           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6790           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6791         else if (difi.lt.-drange(i)) then
6792           difi=difi+drange(i)
6793           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6794           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6795         endif
6796 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6797 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6798       enddo
6799 !      write (iout,*) 'edihcnstr',edihcnstr
6800       return
6801       end subroutine etor
6802 !-----------------------------------------------------------------------------
6803       subroutine etor_d(etors_d)
6804       real(kind=8) :: etors_d
6805       etors_d=0.0d0
6806       return
6807       end subroutine etor_d
6808 #else
6809 !-----------------------------------------------------------------------------
6810       subroutine etor(etors,edihcnstr)
6811 !      implicit real*8 (a-h,o-z)
6812 !      include 'DIMENSIONS'
6813 !      include 'COMMON.VAR'
6814 !      include 'COMMON.GEO'
6815 !      include 'COMMON.LOCAL'
6816 !      include 'COMMON.TORSION'
6817 !      include 'COMMON.INTERACT'
6818 !      include 'COMMON.DERIV'
6819 !      include 'COMMON.CHAIN'
6820 !      include 'COMMON.NAMES'
6821 !      include 'COMMON.IOUNITS'
6822 !      include 'COMMON.FFIELD'
6823 !      include 'COMMON.TORCNSTR'
6824 !      include 'COMMON.CONTROL'
6825       real(kind=8) :: etors,edihcnstr
6826       logical :: lprn
6827 !el local variables
6828       integer :: i,j,iblock,itori,itori1
6829       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6830                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6831 ! Set lprn=.true. for debugging
6832       lprn=.false.
6833 !     lprn=.true.
6834       etors=0.0D0
6835       do i=iphi_start,iphi_end
6836         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6837              .or. itype(i-3,1).eq.ntyp1 &
6838              .or. itype(i,1).eq.ntyp1) cycle
6839         etors_ii=0.0D0
6840          if (iabs(itype(i,1)).eq.20) then
6841          iblock=2
6842          else
6843          iblock=1
6844          endif
6845         itori=itortyp(itype(i-2,1))
6846         itori1=itortyp(itype(i-1,1))
6847         phii=phi(i)
6848         gloci=0.0D0
6849 ! Regular cosine and sine terms
6850         do j=1,nterm(itori,itori1,iblock)
6851           v1ij=v1(j,itori,itori1,iblock)
6852           v2ij=v2(j,itori,itori1,iblock)
6853           cosphi=dcos(j*phii)
6854           sinphi=dsin(j*phii)
6855           etors=etors+v1ij*cosphi+v2ij*sinphi
6856           if (energy_dec) etors_ii=etors_ii+ &
6857                      v1ij*cosphi+v2ij*sinphi
6858           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6859         enddo
6860 ! Lorentz terms
6861 !                         v1
6862 !  E = SUM ----------------------------------- - v1
6863 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6864 !
6865         cosphi=dcos(0.5d0*phii)
6866         sinphi=dsin(0.5d0*phii)
6867         do j=1,nlor(itori,itori1,iblock)
6868           vl1ij=vlor1(j,itori,itori1)
6869           vl2ij=vlor2(j,itori,itori1)
6870           vl3ij=vlor3(j,itori,itori1)
6871           pom=vl2ij*cosphi+vl3ij*sinphi
6872           pom1=1.0d0/(pom*pom+1.0d0)
6873           etors=etors+vl1ij*pom1
6874           if (energy_dec) etors_ii=etors_ii+ &
6875                      vl1ij*pom1
6876           pom=-pom*pom1*pom1
6877           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6878         enddo
6879 ! Subtract the constant term
6880         etors=etors-v0(itori,itori1,iblock)
6881           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6882                'etor',i,etors_ii-v0(itori,itori1,iblock)
6883         if (lprn) &
6884         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6885         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6886         (v1(j,itori,itori1,iblock),j=1,6),&
6887         (v2(j,itori,itori1,iblock),j=1,6)
6888         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6889 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6890       enddo
6891 ! 6/20/98 - dihedral angle constraints
6892       edihcnstr=0.0d0
6893 !      do i=1,ndih_constr
6894       do i=idihconstr_start,idihconstr_end
6895         itori=idih_constr(i)
6896         phii=phi(itori)
6897         difi=pinorm(phii-phi0(i))
6898         if (difi.gt.drange(i)) then
6899           difi=difi-drange(i)
6900           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6901           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6902         else if (difi.lt.-drange(i)) then
6903           difi=difi+drange(i)
6904           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6905           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6906         else
6907           difi=0.0
6908         endif
6909 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6910 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6911 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6912       enddo
6913 !d       write (iout,*) 'edihcnstr',edihcnstr
6914       return
6915       end subroutine etor
6916 !-----------------------------------------------------------------------------
6917       subroutine etor_d(etors_d)
6918 ! 6/23/01 Compute double torsional energy
6919 !      implicit real*8 (a-h,o-z)
6920 !      include 'DIMENSIONS'
6921 !      include 'COMMON.VAR'
6922 !      include 'COMMON.GEO'
6923 !      include 'COMMON.LOCAL'
6924 !      include 'COMMON.TORSION'
6925 !      include 'COMMON.INTERACT'
6926 !      include 'COMMON.DERIV'
6927 !      include 'COMMON.CHAIN'
6928 !      include 'COMMON.NAMES'
6929 !      include 'COMMON.IOUNITS'
6930 !      include 'COMMON.FFIELD'
6931 !      include 'COMMON.TORCNSTR'
6932       real(kind=8) :: etors_d,etors_d_ii
6933       logical :: lprn
6934 !el local variables
6935       integer :: i,j,k,l,itori,itori1,itori2,iblock
6936       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6937                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6938                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6939                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6940 ! Set lprn=.true. for debugging
6941       lprn=.false.
6942 !     lprn=.true.
6943       etors_d=0.0D0
6944 !      write(iout,*) "a tu??"
6945       do i=iphid_start,iphid_end
6946         etors_d_ii=0.0D0
6947         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6948             .or. itype(i-3,1).eq.ntyp1 &
6949             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6950         itori=itortyp(itype(i-2,1))
6951         itori1=itortyp(itype(i-1,1))
6952         itori2=itortyp(itype(i,1))
6953         phii=phi(i)
6954         phii1=phi(i+1)
6955         gloci1=0.0D0
6956         gloci2=0.0D0
6957         iblock=1
6958         if (iabs(itype(i+1,1)).eq.20) iblock=2
6959
6960 ! Regular cosine and sine terms
6961         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6962           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6963           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6964           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6965           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6966           cosphi1=dcos(j*phii)
6967           sinphi1=dsin(j*phii)
6968           cosphi2=dcos(j*phii1)
6969           sinphi2=dsin(j*phii1)
6970           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6971            v2cij*cosphi2+v2sij*sinphi2
6972           if (energy_dec) etors_d_ii=etors_d_ii+ &
6973            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6974           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6975           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6976         enddo
6977         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6978           do l=1,k-1
6979             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6980             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6981             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6982             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6983             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6984             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6985             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6986             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6987             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6988               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6989             if (energy_dec) etors_d_ii=etors_d_ii+ &
6990               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6991               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6992             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6993               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6994             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6995               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6996           enddo
6997         enddo
6998         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6999                             'etor_d',i,etors_d_ii
7000         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7001         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7002       enddo
7003       return
7004       end subroutine etor_d
7005 #endif
7006 !-----------------------------------------------------------------------------
7007       subroutine eback_sc_corr(esccor)
7008 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7009 !        conformational states; temporarily implemented as differences
7010 !        between UNRES torsional potentials (dependent on three types of
7011 !        residues) and the torsional potentials dependent on all 20 types
7012 !        of residues computed from AM1  energy surfaces of terminally-blocked
7013 !        amino-acid residues.
7014 !      implicit real*8 (a-h,o-z)
7015 !      include 'DIMENSIONS'
7016 !      include 'COMMON.VAR'
7017 !      include 'COMMON.GEO'
7018 !      include 'COMMON.LOCAL'
7019 !      include 'COMMON.TORSION'
7020 !      include 'COMMON.SCCOR'
7021 !      include 'COMMON.INTERACT'
7022 !      include 'COMMON.DERIV'
7023 !      include 'COMMON.CHAIN'
7024 !      include 'COMMON.NAMES'
7025 !      include 'COMMON.IOUNITS'
7026 !      include 'COMMON.FFIELD'
7027 !      include 'COMMON.CONTROL'
7028       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7029                    cosphi,sinphi
7030       logical :: lprn
7031       integer :: i,interty,j,isccori,isccori1,intertyp
7032 ! Set lprn=.true. for debugging
7033       lprn=.false.
7034 !      lprn=.true.
7035 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7036       esccor=0.0D0
7037       do i=itau_start,itau_end
7038         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7039         esccor_ii=0.0D0
7040         isccori=isccortyp(itype(i-2,1))
7041         isccori1=isccortyp(itype(i-1,1))
7042
7043 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7044         phii=phi(i)
7045         do intertyp=1,3 !intertyp
7046          esccor_ii=0.0D0
7047 !c Added 09 May 2012 (Adasko)
7048 !c  Intertyp means interaction type of backbone mainchain correlation:
7049 !   1 = SC...Ca...Ca...Ca
7050 !   2 = Ca...Ca...Ca...SC
7051 !   3 = SC...Ca...Ca...SCi
7052         gloci=0.0D0
7053         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7054             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7055             (itype(i-1,1).eq.ntyp1))) &
7056           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7057            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7058            .or.(itype(i,1).eq.ntyp1))) &
7059           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7060             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7061             (itype(i-3,1).eq.ntyp1)))) cycle
7062         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7063         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7064        cycle
7065        do j=1,nterm_sccor(isccori,isccori1)
7066           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7067           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7068           cosphi=dcos(j*tauangle(intertyp,i))
7069           sinphi=dsin(j*tauangle(intertyp,i))
7070           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7071           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7072           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7073         enddo
7074         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7075                                 'esccor',i,intertyp,esccor_ii
7076 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7077         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7078         if (lprn) &
7079         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7080         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7081         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7082         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7083         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7084        enddo !intertyp
7085       enddo
7086
7087       return
7088       end subroutine eback_sc_corr
7089 !-----------------------------------------------------------------------------
7090       subroutine multibody(ecorr)
7091 ! This subroutine calculates multi-body contributions to energy following
7092 ! the idea of Skolnick et al. If side chains I and J make a contact and
7093 ! at the same time side chains I+1 and J+1 make a contact, an extra
7094 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7095 !      implicit real*8 (a-h,o-z)
7096 !      include 'DIMENSIONS'
7097 !      include 'COMMON.IOUNITS'
7098 !      include 'COMMON.DERIV'
7099 !      include 'COMMON.INTERACT'
7100 !      include 'COMMON.CONTACTS'
7101       real(kind=8),dimension(3) :: gx,gx1
7102       logical :: lprn
7103       real(kind=8) :: ecorr
7104       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7105 ! Set lprn=.true. for debugging
7106       lprn=.false.
7107
7108       if (lprn) then
7109         write (iout,'(a)') 'Contact function values:'
7110         do i=nnt,nct-2
7111           write (iout,'(i2,20(1x,i2,f10.5))') &
7112               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7113         enddo
7114       endif
7115       ecorr=0.0D0
7116
7117 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7118 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7119       do i=nnt,nct
7120         do j=1,3
7121           gradcorr(j,i)=0.0D0
7122           gradxorr(j,i)=0.0D0
7123         enddo
7124       enddo
7125       do i=nnt,nct-2
7126
7127         DO ISHIFT = 3,4
7128
7129         i1=i+ishift
7130         num_conti=num_cont(i)
7131         num_conti1=num_cont(i1)
7132         do jj=1,num_conti
7133           j=jcont(jj,i)
7134           do kk=1,num_conti1
7135             j1=jcont(kk,i1)
7136             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7137 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7138 !d   &                   ' ishift=',ishift
7139 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7140 ! The system gains extra energy.
7141               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7142             endif   ! j1==j+-ishift
7143           enddo     ! kk
7144         enddo       ! jj
7145
7146         ENDDO ! ISHIFT
7147
7148       enddo         ! i
7149       return
7150       end subroutine multibody
7151 !-----------------------------------------------------------------------------
7152       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7153 !      implicit real*8 (a-h,o-z)
7154 !      include 'DIMENSIONS'
7155 !      include 'COMMON.IOUNITS'
7156 !      include 'COMMON.DERIV'
7157 !      include 'COMMON.INTERACT'
7158 !      include 'COMMON.CONTACTS'
7159       real(kind=8),dimension(3) :: gx,gx1
7160       logical :: lprn
7161       integer :: i,j,k,l,jj,kk,m,ll
7162       real(kind=8) :: eij,ekl
7163       lprn=.false.
7164       eij=facont(jj,i)
7165       ekl=facont(kk,k)
7166 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7167 ! Calculate the multi-body contribution to energy.
7168 ! Calculate multi-body contributions to the gradient.
7169 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7170 !d   & k,l,(gacont(m,kk,k),m=1,3)
7171       do m=1,3
7172         gx(m) =ekl*gacont(m,jj,i)
7173         gx1(m)=eij*gacont(m,kk,k)
7174         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7175         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7176         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7177         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7178       enddo
7179       do m=i,j-1
7180         do ll=1,3
7181           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7182         enddo
7183       enddo
7184       do m=k,l-1
7185         do ll=1,3
7186           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7187         enddo
7188       enddo
7189       esccorr=-eij*ekl
7190       return
7191       end function esccorr
7192 !-----------------------------------------------------------------------------
7193       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7194 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7195 !      implicit real*8 (a-h,o-z)
7196 !      include 'DIMENSIONS'
7197 !      include 'COMMON.IOUNITS'
7198 #ifdef MPI
7199       include "mpif.h"
7200 !      integer :: maxconts !max_cont=maxconts  =nres/4
7201       integer,parameter :: max_dim=26
7202       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7203       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7204 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7205 !el      common /przechowalnia/ zapas
7206       integer :: status(MPI_STATUS_SIZE)
7207       integer,dimension((nres/4)*2) :: req !maxconts*2
7208       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7209 #endif
7210 !      include 'COMMON.SETUP'
7211 !      include 'COMMON.FFIELD'
7212 !      include 'COMMON.DERIV'
7213 !      include 'COMMON.INTERACT'
7214 !      include 'COMMON.CONTACTS'
7215 !      include 'COMMON.CONTROL'
7216 !      include 'COMMON.LOCAL'
7217       real(kind=8),dimension(3) :: gx,gx1
7218       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7219       logical :: lprn,ldone
7220 !el local variables
7221       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7222               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7223
7224 ! Set lprn=.true. for debugging
7225       lprn=.false.
7226 #ifdef MPI
7227 !      maxconts=nres/4
7228       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7229       n_corr=0
7230       n_corr1=0
7231       if (nfgtasks.le.1) goto 30
7232       if (lprn) then
7233         write (iout,'(a)') 'Contact function values before RECEIVE:'
7234         do i=nnt,nct-2
7235           write (iout,'(2i3,50(1x,i2,f5.2))') &
7236           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7237           j=1,num_cont_hb(i))
7238         enddo
7239       endif
7240       call flush(iout)
7241       do i=1,ntask_cont_from
7242         ncont_recv(i)=0
7243       enddo
7244       do i=1,ntask_cont_to
7245         ncont_sent(i)=0
7246       enddo
7247 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7248 !     & ntask_cont_to
7249 ! Make the list of contacts to send to send to other procesors
7250 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7251 !      call flush(iout)
7252       do i=iturn3_start,iturn3_end
7253 !        write (iout,*) "make contact list turn3",i," num_cont",
7254 !     &    num_cont_hb(i)
7255         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7256       enddo
7257       do i=iturn4_start,iturn4_end
7258 !        write (iout,*) "make contact list turn4",i," num_cont",
7259 !     &   num_cont_hb(i)
7260         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7261       enddo
7262       do ii=1,nat_sent
7263         i=iat_sent(ii)
7264 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7265 !     &    num_cont_hb(i)
7266         do j=1,num_cont_hb(i)
7267         do k=1,4
7268           jjc=jcont_hb(j,i)
7269           iproc=iint_sent_local(k,jjc,ii)
7270 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7271           if (iproc.gt.0) then
7272             ncont_sent(iproc)=ncont_sent(iproc)+1
7273             nn=ncont_sent(iproc)
7274             zapas(1,nn,iproc)=i
7275             zapas(2,nn,iproc)=jjc
7276             zapas(3,nn,iproc)=facont_hb(j,i)
7277             zapas(4,nn,iproc)=ees0p(j,i)
7278             zapas(5,nn,iproc)=ees0m(j,i)
7279             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7280             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7281             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7282             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7283             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7284             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7285             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7286             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7287             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7288             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7289             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7290             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7291             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7292             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7293             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7294             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7295             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7296             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7297             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7298             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7299             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7300           endif
7301         enddo
7302         enddo
7303       enddo
7304       if (lprn) then
7305       write (iout,*) &
7306         "Numbers of contacts to be sent to other processors",&
7307         (ncont_sent(i),i=1,ntask_cont_to)
7308       write (iout,*) "Contacts sent"
7309       do ii=1,ntask_cont_to
7310         nn=ncont_sent(ii)
7311         iproc=itask_cont_to(ii)
7312         write (iout,*) nn," contacts to processor",iproc,&
7313          " of CONT_TO_COMM group"
7314         do i=1,nn
7315           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7316         enddo
7317       enddo
7318       call flush(iout)
7319       endif
7320       CorrelType=477
7321       CorrelID=fg_rank+1
7322       CorrelType1=478
7323       CorrelID1=nfgtasks+fg_rank+1
7324       ireq=0
7325 ! Receive the numbers of needed contacts from other processors
7326       do ii=1,ntask_cont_from
7327         iproc=itask_cont_from(ii)
7328         ireq=ireq+1
7329         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7330           FG_COMM,req(ireq),IERR)
7331       enddo
7332 !      write (iout,*) "IRECV ended"
7333 !      call flush(iout)
7334 ! Send the number of contacts needed by other processors
7335       do ii=1,ntask_cont_to
7336         iproc=itask_cont_to(ii)
7337         ireq=ireq+1
7338         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7339           FG_COMM,req(ireq),IERR)
7340       enddo
7341 !      write (iout,*) "ISEND ended"
7342 !      write (iout,*) "number of requests (nn)",ireq
7343       call flush(iout)
7344       if (ireq.gt.0) &
7345         call MPI_Waitall(ireq,req,status_array,ierr)
7346 !      write (iout,*)
7347 !     &  "Numbers of contacts to be received from other processors",
7348 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7349 !      call flush(iout)
7350 ! Receive contacts
7351       ireq=0
7352       do ii=1,ntask_cont_from
7353         iproc=itask_cont_from(ii)
7354         nn=ncont_recv(ii)
7355 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7356 !     &   " of CONT_TO_COMM group"
7357         call flush(iout)
7358         if (nn.gt.0) then
7359           ireq=ireq+1
7360           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7361           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7362 !          write (iout,*) "ireq,req",ireq,req(ireq)
7363         endif
7364       enddo
7365 ! Send the contacts to processors that need them
7366       do ii=1,ntask_cont_to
7367         iproc=itask_cont_to(ii)
7368         nn=ncont_sent(ii)
7369 !        write (iout,*) nn," contacts to processor",iproc,
7370 !     &   " of CONT_TO_COMM group"
7371         if (nn.gt.0) then
7372           ireq=ireq+1
7373           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7374             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7375 !          write (iout,*) "ireq,req",ireq,req(ireq)
7376 !          do i=1,nn
7377 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7378 !          enddo
7379         endif
7380       enddo
7381 !      write (iout,*) "number of requests (contacts)",ireq
7382 !      write (iout,*) "req",(req(i),i=1,4)
7383 !      call flush(iout)
7384       if (ireq.gt.0) &
7385        call MPI_Waitall(ireq,req,status_array,ierr)
7386       do iii=1,ntask_cont_from
7387         iproc=itask_cont_from(iii)
7388         nn=ncont_recv(iii)
7389         if (lprn) then
7390         write (iout,*) "Received",nn," contacts from processor",iproc,&
7391          " of CONT_FROM_COMM group"
7392         call flush(iout)
7393         do i=1,nn
7394           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7395         enddo
7396         call flush(iout)
7397         endif
7398         do i=1,nn
7399           ii=zapas_recv(1,i,iii)
7400 ! Flag the received contacts to prevent double-counting
7401           jj=-zapas_recv(2,i,iii)
7402 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7403 !          call flush(iout)
7404           nnn=num_cont_hb(ii)+1
7405           num_cont_hb(ii)=nnn
7406           jcont_hb(nnn,ii)=jj
7407           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7408           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7409           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7410           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7411           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7412           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7413           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7414           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7415           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7416           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7417           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7418           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7419           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7420           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7421           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7422           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7423           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7424           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7425           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7426           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7427           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7428           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7429           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7430           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7431         enddo
7432       enddo
7433       call flush(iout)
7434       if (lprn) then
7435         write (iout,'(a)') 'Contact function values after receive:'
7436         do i=nnt,nct-2
7437           write (iout,'(2i3,50(1x,i3,f5.2))') &
7438           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7439           j=1,num_cont_hb(i))
7440         enddo
7441         call flush(iout)
7442       endif
7443    30 continue
7444 #endif
7445       if (lprn) then
7446         write (iout,'(a)') 'Contact function values:'
7447         do i=nnt,nct-2
7448           write (iout,'(2i3,50(1x,i3,f5.2))') &
7449           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7450           j=1,num_cont_hb(i))
7451         enddo
7452       endif
7453       ecorr=0.0D0
7454
7455 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7456 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7457 ! Remove the loop below after debugging !!!
7458       do i=nnt,nct
7459         do j=1,3
7460           gradcorr(j,i)=0.0D0
7461           gradxorr(j,i)=0.0D0
7462         enddo
7463       enddo
7464 ! Calculate the local-electrostatic correlation terms
7465       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7466         i1=i+1
7467         num_conti=num_cont_hb(i)
7468         num_conti1=num_cont_hb(i+1)
7469         do jj=1,num_conti
7470           j=jcont_hb(jj,i)
7471           jp=iabs(j)
7472           do kk=1,num_conti1
7473             j1=jcont_hb(kk,i1)
7474             jp1=iabs(j1)
7475 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7476 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7477             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7478                 .or. j.lt.0 .and. j1.gt.0) .and. &
7479                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7480 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7481 ! The system gains extra energy.
7482               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7483               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7484                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7485               n_corr=n_corr+1
7486             else if (j1.eq.j) then
7487 ! Contacts I-J and I-(J+1) occur simultaneously.
7488 ! The system loses extra energy.
7489 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7490             endif
7491           enddo ! kk
7492           do kk=1,num_conti
7493             j1=jcont_hb(kk,i)
7494 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7495 !    &         ' jj=',jj,' kk=',kk
7496             if (j1.eq.j+1) then
7497 ! Contacts I-J and (I+1)-J occur simultaneously.
7498 ! The system loses extra energy.
7499 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7500             endif ! j1==j+1
7501           enddo ! kk
7502         enddo ! jj
7503       enddo ! i
7504       return
7505       end subroutine multibody_hb
7506 !-----------------------------------------------------------------------------
7507       subroutine add_hb_contact(ii,jj,itask)
7508 !      implicit real*8 (a-h,o-z)
7509 !      include "DIMENSIONS"
7510 !      include "COMMON.IOUNITS"
7511 !      include "COMMON.CONTACTS"
7512 !      integer,parameter :: maxconts=nres/4
7513       integer,parameter :: max_dim=26
7514       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7515 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7516 !      common /przechowalnia/ zapas
7517       integer :: i,j,ii,jj,iproc,nn,jjc
7518       integer,dimension(4) :: itask
7519 !      write (iout,*) "itask",itask
7520       do i=1,2
7521         iproc=itask(i)
7522         if (iproc.gt.0) then
7523           do j=1,num_cont_hb(ii)
7524             jjc=jcont_hb(j,ii)
7525 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7526             if (jjc.eq.jj) then
7527               ncont_sent(iproc)=ncont_sent(iproc)+1
7528               nn=ncont_sent(iproc)
7529               zapas(1,nn,iproc)=ii
7530               zapas(2,nn,iproc)=jjc
7531               zapas(3,nn,iproc)=facont_hb(j,ii)
7532               zapas(4,nn,iproc)=ees0p(j,ii)
7533               zapas(5,nn,iproc)=ees0m(j,ii)
7534               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7535               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7536               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7537               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7538               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7539               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7540               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7541               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7542               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7543               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7544               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7545               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7546               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7547               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7548               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7549               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7550               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7551               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7552               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7553               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7554               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7555               exit
7556             endif
7557           enddo
7558         endif
7559       enddo
7560       return
7561       end subroutine add_hb_contact
7562 !-----------------------------------------------------------------------------
7563       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7564 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7565 !      implicit real*8 (a-h,o-z)
7566 !      include 'DIMENSIONS'
7567 !      include 'COMMON.IOUNITS'
7568       integer,parameter :: max_dim=70
7569 #ifdef MPI
7570       include "mpif.h"
7571 !      integer :: maxconts !max_cont=maxconts=nres/4
7572       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7573       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7574 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7575 !      common /przechowalnia/ zapas
7576       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7577         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7578         ierr,iii,nnn
7579 #endif
7580 !      include 'COMMON.SETUP'
7581 !      include 'COMMON.FFIELD'
7582 !      include 'COMMON.DERIV'
7583 !      include 'COMMON.LOCAL'
7584 !      include 'COMMON.INTERACT'
7585 !      include 'COMMON.CONTACTS'
7586 !      include 'COMMON.CHAIN'
7587 !      include 'COMMON.CONTROL'
7588       real(kind=8),dimension(3) :: gx,gx1
7589       integer,dimension(nres) :: num_cont_hb_old
7590       logical :: lprn,ldone
7591 !EL      double precision eello4,eello5,eelo6,eello_turn6
7592 !EL      external eello4,eello5,eello6,eello_turn6
7593 !el local variables
7594       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7595               j1,jp1,i1,num_conti1
7596       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7597       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7598
7599 ! Set lprn=.true. for debugging
7600       lprn=.false.
7601       eturn6=0.0d0
7602 #ifdef MPI
7603 !      maxconts=nres/4
7604       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7605       do i=1,nres
7606         num_cont_hb_old(i)=num_cont_hb(i)
7607       enddo
7608       n_corr=0
7609       n_corr1=0
7610       if (nfgtasks.le.1) goto 30
7611       if (lprn) then
7612         write (iout,'(a)') 'Contact function values before RECEIVE:'
7613         do i=nnt,nct-2
7614           write (iout,'(2i3,50(1x,i2,f5.2))') &
7615           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7616           j=1,num_cont_hb(i))
7617         enddo
7618       endif
7619       call flush(iout)
7620       do i=1,ntask_cont_from
7621         ncont_recv(i)=0
7622       enddo
7623       do i=1,ntask_cont_to
7624         ncont_sent(i)=0
7625       enddo
7626 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7627 !     & ntask_cont_to
7628 ! Make the list of contacts to send to send to other procesors
7629       do i=iturn3_start,iturn3_end
7630 !        write (iout,*) "make contact list turn3",i," num_cont",
7631 !     &    num_cont_hb(i)
7632         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7633       enddo
7634       do i=iturn4_start,iturn4_end
7635 !        write (iout,*) "make contact list turn4",i," num_cont",
7636 !     &   num_cont_hb(i)
7637         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7638       enddo
7639       do ii=1,nat_sent
7640         i=iat_sent(ii)
7641 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7642 !     &    num_cont_hb(i)
7643         do j=1,num_cont_hb(i)
7644         do k=1,4
7645           jjc=jcont_hb(j,i)
7646           iproc=iint_sent_local(k,jjc,ii)
7647 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7648           if (iproc.ne.0) then
7649             ncont_sent(iproc)=ncont_sent(iproc)+1
7650             nn=ncont_sent(iproc)
7651             zapas(1,nn,iproc)=i
7652             zapas(2,nn,iproc)=jjc
7653             zapas(3,nn,iproc)=d_cont(j,i)
7654             ind=3
7655             do kk=1,3
7656               ind=ind+1
7657               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7658             enddo
7659             do kk=1,2
7660               do ll=1,2
7661                 ind=ind+1
7662                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7663               enddo
7664             enddo
7665             do jj=1,5
7666               do kk=1,3
7667                 do ll=1,2
7668                   do mm=1,2
7669                     ind=ind+1
7670                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7671                   enddo
7672                 enddo
7673               enddo
7674             enddo
7675           endif
7676         enddo
7677         enddo
7678       enddo
7679       if (lprn) then
7680       write (iout,*) &
7681         "Numbers of contacts to be sent to other processors",&
7682         (ncont_sent(i),i=1,ntask_cont_to)
7683       write (iout,*) "Contacts sent"
7684       do ii=1,ntask_cont_to
7685         nn=ncont_sent(ii)
7686         iproc=itask_cont_to(ii)
7687         write (iout,*) nn," contacts to processor",iproc,&
7688          " of CONT_TO_COMM group"
7689         do i=1,nn
7690           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7691         enddo
7692       enddo
7693       call flush(iout)
7694       endif
7695       CorrelType=477
7696       CorrelID=fg_rank+1
7697       CorrelType1=478
7698       CorrelID1=nfgtasks+fg_rank+1
7699       ireq=0
7700 ! Receive the numbers of needed contacts from other processors
7701       do ii=1,ntask_cont_from
7702         iproc=itask_cont_from(ii)
7703         ireq=ireq+1
7704         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7705           FG_COMM,req(ireq),IERR)
7706       enddo
7707 !      write (iout,*) "IRECV ended"
7708 !      call flush(iout)
7709 ! Send the number of contacts needed by other processors
7710       do ii=1,ntask_cont_to
7711         iproc=itask_cont_to(ii)
7712         ireq=ireq+1
7713         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7714           FG_COMM,req(ireq),IERR)
7715       enddo
7716 !      write (iout,*) "ISEND ended"
7717 !      write (iout,*) "number of requests (nn)",ireq
7718       call flush(iout)
7719       if (ireq.gt.0) &
7720         call MPI_Waitall(ireq,req,status_array,ierr)
7721 !      write (iout,*)
7722 !     &  "Numbers of contacts to be received from other processors",
7723 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7724 !      call flush(iout)
7725 ! Receive contacts
7726       ireq=0
7727       do ii=1,ntask_cont_from
7728         iproc=itask_cont_from(ii)
7729         nn=ncont_recv(ii)
7730 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7731 !     &   " of CONT_TO_COMM group"
7732         call flush(iout)
7733         if (nn.gt.0) then
7734           ireq=ireq+1
7735           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7736           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7737 !          write (iout,*) "ireq,req",ireq,req(ireq)
7738         endif
7739       enddo
7740 ! Send the contacts to processors that need them
7741       do ii=1,ntask_cont_to
7742         iproc=itask_cont_to(ii)
7743         nn=ncont_sent(ii)
7744 !        write (iout,*) nn," contacts to processor",iproc,
7745 !     &   " of CONT_TO_COMM group"
7746         if (nn.gt.0) then
7747           ireq=ireq+1
7748           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7749             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7750 !          write (iout,*) "ireq,req",ireq,req(ireq)
7751 !          do i=1,nn
7752 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7753 !          enddo
7754         endif
7755       enddo
7756 !      write (iout,*) "number of requests (contacts)",ireq
7757 !      write (iout,*) "req",(req(i),i=1,4)
7758 !      call flush(iout)
7759       if (ireq.gt.0) &
7760        call MPI_Waitall(ireq,req,status_array,ierr)
7761       do iii=1,ntask_cont_from
7762         iproc=itask_cont_from(iii)
7763         nn=ncont_recv(iii)
7764         if (lprn) then
7765         write (iout,*) "Received",nn," contacts from processor",iproc,&
7766          " of CONT_FROM_COMM group"
7767         call flush(iout)
7768         do i=1,nn
7769           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7770         enddo
7771         call flush(iout)
7772         endif
7773         do i=1,nn
7774           ii=zapas_recv(1,i,iii)
7775 ! Flag the received contacts to prevent double-counting
7776           jj=-zapas_recv(2,i,iii)
7777 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7778 !          call flush(iout)
7779           nnn=num_cont_hb(ii)+1
7780           num_cont_hb(ii)=nnn
7781           jcont_hb(nnn,ii)=jj
7782           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7783           ind=3
7784           do kk=1,3
7785             ind=ind+1
7786             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7787           enddo
7788           do kk=1,2
7789             do ll=1,2
7790               ind=ind+1
7791               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7792             enddo
7793           enddo
7794           do jj=1,5
7795             do kk=1,3
7796               do ll=1,2
7797                 do mm=1,2
7798                   ind=ind+1
7799                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7800                 enddo
7801               enddo
7802             enddo
7803           enddo
7804         enddo
7805       enddo
7806       call flush(iout)
7807       if (lprn) then
7808         write (iout,'(a)') 'Contact function values after receive:'
7809         do i=nnt,nct-2
7810           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7811           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7812           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7813         enddo
7814         call flush(iout)
7815       endif
7816    30 continue
7817 #endif
7818       if (lprn) then
7819         write (iout,'(a)') 'Contact function values:'
7820         do i=nnt,nct-2
7821           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7822           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7823           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7824         enddo
7825       endif
7826       ecorr=0.0D0
7827       ecorr5=0.0d0
7828       ecorr6=0.0d0
7829
7830 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7831 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7832 ! Remove the loop below after debugging !!!
7833       do i=nnt,nct
7834         do j=1,3
7835           gradcorr(j,i)=0.0D0
7836           gradxorr(j,i)=0.0D0
7837         enddo
7838       enddo
7839 ! Calculate the dipole-dipole interaction energies
7840       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7841       do i=iatel_s,iatel_e+1
7842         num_conti=num_cont_hb(i)
7843         do jj=1,num_conti
7844           j=jcont_hb(jj,i)
7845 #ifdef MOMENT
7846           call dipole(i,j,jj)
7847 #endif
7848         enddo
7849       enddo
7850       endif
7851 ! Calculate the local-electrostatic correlation terms
7852 !                write (iout,*) "gradcorr5 in eello5 before loop"
7853 !                do iii=1,nres
7854 !                  write (iout,'(i5,3f10.5)')
7855 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7856 !                enddo
7857       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7858 !        write (iout,*) "corr loop i",i
7859         i1=i+1
7860         num_conti=num_cont_hb(i)
7861         num_conti1=num_cont_hb(i+1)
7862         do jj=1,num_conti
7863           j=jcont_hb(jj,i)
7864           jp=iabs(j)
7865           do kk=1,num_conti1
7866             j1=jcont_hb(kk,i1)
7867             jp1=iabs(j1)
7868 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7869 !     &         ' jj=',jj,' kk=',kk
7870 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7871             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7872                 .or. j.lt.0 .and. j1.gt.0) .and. &
7873                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7874 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7875 ! The system gains extra energy.
7876               n_corr=n_corr+1
7877               sqd1=dsqrt(d_cont(jj,i))
7878               sqd2=dsqrt(d_cont(kk,i1))
7879               sred_geom = sqd1*sqd2
7880               IF (sred_geom.lt.cutoff_corr) THEN
7881                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7882                   ekont,fprimcont)
7883 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7884 !d     &         ' jj=',jj,' kk=',kk
7885                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7886                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7887                 do l=1,3
7888                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7889                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7890                 enddo
7891                 n_corr1=n_corr1+1
7892 !d               write (iout,*) 'sred_geom=',sred_geom,
7893 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7894 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7895 !d               write (iout,*) "g_contij",g_contij
7896 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7897 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7898                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7899                 if (wcorr4.gt.0.0d0) &
7900                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7901                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7902                        write (iout,'(a6,4i5,0pf7.3)') &
7903                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7904 !                write (iout,*) "gradcorr5 before eello5"
7905 !                do iii=1,nres
7906 !                  write (iout,'(i5,3f10.5)')
7907 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7908 !                enddo
7909                 if (wcorr5.gt.0.0d0) &
7910                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7911 !                write (iout,*) "gradcorr5 after eello5"
7912 !                do iii=1,nres
7913 !                  write (iout,'(i5,3f10.5)')
7914 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7915 !                enddo
7916                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7917                        write (iout,'(a6,4i5,0pf7.3)') &
7918                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7919 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7920 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7921                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7922                      .or. wturn6.eq.0.0d0))then
7923 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7924                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7925                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7926                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7927 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7928 !d     &            'ecorr6=',ecorr6
7929 !d                write (iout,'(4e15.5)') sred_geom,
7930 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7931 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7932 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7933                 else if (wturn6.gt.0.0d0 &
7934                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7935 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7936                   eturn6=eturn6+eello_turn6(i,jj,kk)
7937                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7938                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7939 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7940                 endif
7941               ENDIF
7942 1111          continue
7943             endif
7944           enddo ! kk
7945         enddo ! jj
7946       enddo ! i
7947       do i=1,nres
7948         num_cont_hb(i)=num_cont_hb_old(i)
7949       enddo
7950 !                write (iout,*) "gradcorr5 in eello5"
7951 !                do iii=1,nres
7952 !                  write (iout,'(i5,3f10.5)')
7953 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7954 !                enddo
7955       return
7956       end subroutine multibody_eello
7957 !-----------------------------------------------------------------------------
7958       subroutine add_hb_contact_eello(ii,jj,itask)
7959 !      implicit real*8 (a-h,o-z)
7960 !      include "DIMENSIONS"
7961 !      include "COMMON.IOUNITS"
7962 !      include "COMMON.CONTACTS"
7963 !      integer,parameter :: maxconts=nres/4
7964       integer,parameter :: max_dim=70
7965       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7966 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7967 !      common /przechowalnia/ zapas
7968
7969       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7970       integer,dimension(4) ::itask
7971 !      write (iout,*) "itask",itask
7972       do i=1,2
7973         iproc=itask(i)
7974         if (iproc.gt.0) then
7975           do j=1,num_cont_hb(ii)
7976             jjc=jcont_hb(j,ii)
7977 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7978             if (jjc.eq.jj) then
7979               ncont_sent(iproc)=ncont_sent(iproc)+1
7980               nn=ncont_sent(iproc)
7981               zapas(1,nn,iproc)=ii
7982               zapas(2,nn,iproc)=jjc
7983               zapas(3,nn,iproc)=d_cont(j,ii)
7984               ind=3
7985               do kk=1,3
7986                 ind=ind+1
7987                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7988               enddo
7989               do kk=1,2
7990                 do ll=1,2
7991                   ind=ind+1
7992                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7993                 enddo
7994               enddo
7995               do jj=1,5
7996                 do kk=1,3
7997                   do ll=1,2
7998                     do mm=1,2
7999                       ind=ind+1
8000                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8001                     enddo
8002                   enddo
8003                 enddo
8004               enddo
8005               exit
8006             endif
8007           enddo
8008         endif
8009       enddo
8010       return
8011       end subroutine add_hb_contact_eello
8012 !-----------------------------------------------------------------------------
8013       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8014 !      implicit real*8 (a-h,o-z)
8015 !      include 'DIMENSIONS'
8016 !      include 'COMMON.IOUNITS'
8017 !      include 'COMMON.DERIV'
8018 !      include 'COMMON.INTERACT'
8019 !      include 'COMMON.CONTACTS'
8020       real(kind=8),dimension(3) :: gx,gx1
8021       logical :: lprn
8022 !el local variables
8023       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8024       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8025                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8026                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8027                    rlocshield
8028
8029       lprn=.false.
8030       eij=facont_hb(jj,i)
8031       ekl=facont_hb(kk,k)
8032       ees0pij=ees0p(jj,i)
8033       ees0pkl=ees0p(kk,k)
8034       ees0mij=ees0m(jj,i)
8035       ees0mkl=ees0m(kk,k)
8036       ekont=eij*ekl
8037       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8038 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8039 ! Following 4 lines for diagnostics.
8040 !d    ees0pkl=0.0D0
8041 !d    ees0pij=1.0D0
8042 !d    ees0mkl=0.0D0
8043 !d    ees0mij=1.0D0
8044 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8045 !     & 'Contacts ',i,j,
8046 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8047 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8048 !     & 'gradcorr_long'
8049 ! Calculate the multi-body contribution to energy.
8050 !      ecorr=ecorr+ekont*ees
8051 ! Calculate multi-body contributions to the gradient.
8052       coeffpees0pij=coeffp*ees0pij
8053       coeffmees0mij=coeffm*ees0mij
8054       coeffpees0pkl=coeffp*ees0pkl
8055       coeffmees0mkl=coeffm*ees0mkl
8056       do ll=1,3
8057 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8058         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8059         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8060         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8061         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8062         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8063         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8064 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8065         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8066         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8067         coeffmees0mij*gacontm_hb1(ll,kk,k))
8068         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8069         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8070         coeffmees0mij*gacontm_hb2(ll,kk,k))
8071         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8072            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8073            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8074         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8075         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8076         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8077            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8078            coeffmees0mij*gacontm_hb3(ll,kk,k))
8079         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8080         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8081 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8082       enddo
8083 !      write (iout,*)
8084 !grad      do m=i+1,j-1
8085 !grad        do ll=1,3
8086 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8087 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8088 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8089 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8090 !grad        enddo
8091 !grad      enddo
8092 !grad      do m=k+1,l-1
8093 !grad        do ll=1,3
8094 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8095 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8096 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8097 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8098 !grad        enddo
8099 !grad      enddo
8100 !      write (iout,*) "ehbcorr",ekont*ees
8101       ehbcorr=ekont*ees
8102       if (shield_mode.gt.0) then
8103        j=ees0plist(jj,i)
8104        l=ees0plist(kk,k)
8105 !C        print *,i,j,fac_shield(i),fac_shield(j),
8106 !C     &fac_shield(k),fac_shield(l)
8107         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8108            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8109           do ilist=1,ishield_list(i)
8110            iresshield=shield_list(ilist,i)
8111            do m=1,3
8112            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8113            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8114                    rlocshield  &
8115             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8116             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8117             +rlocshield
8118            enddo
8119           enddo
8120           do ilist=1,ishield_list(j)
8121            iresshield=shield_list(ilist,j)
8122            do m=1,3
8123            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8124            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8125                    rlocshield &
8126             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8127            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8128             +rlocshield
8129            enddo
8130           enddo
8131
8132           do ilist=1,ishield_list(k)
8133            iresshield=shield_list(ilist,k)
8134            do m=1,3
8135            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8136            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8137                    rlocshield &
8138             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8139            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8140             +rlocshield
8141            enddo
8142           enddo
8143           do ilist=1,ishield_list(l)
8144            iresshield=shield_list(ilist,l)
8145            do m=1,3
8146            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8147            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8148                    rlocshield &
8149             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8150            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8151             +rlocshield
8152            enddo
8153           enddo
8154           do m=1,3
8155             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8156                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8157             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8158                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8159             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8160                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8161             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8162                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8163
8164             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8165                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8166             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8167                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8168             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8169                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8170             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8171                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8172
8173            enddo
8174       endif
8175       endif
8176       return
8177       end function ehbcorr
8178 #ifdef MOMENT
8179 !-----------------------------------------------------------------------------
8180       subroutine dipole(i,j,jj)
8181 !      implicit real*8 (a-h,o-z)
8182 !      include 'DIMENSIONS'
8183 !      include 'COMMON.IOUNITS'
8184 !      include 'COMMON.CHAIN'
8185 !      include 'COMMON.FFIELD'
8186 !      include 'COMMON.DERIV'
8187 !      include 'COMMON.INTERACT'
8188 !      include 'COMMON.CONTACTS'
8189 !      include 'COMMON.TORSION'
8190 !      include 'COMMON.VAR'
8191 !      include 'COMMON.GEO'
8192       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8193       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8194       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8195
8196       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8197       allocate(dipderx(3,5,4,maxconts,nres))
8198 !
8199
8200       iti1 = itortyp(itype(i+1,1))
8201       if (j.lt.nres-1) then
8202         itj1 = itortyp(itype(j+1,1))
8203       else
8204         itj1=ntortyp+1
8205       endif
8206       do iii=1,2
8207         dipi(iii,1)=Ub2(iii,i)
8208         dipderi(iii)=Ub2der(iii,i)
8209         dipi(iii,2)=b1(iii,iti1)
8210         dipj(iii,1)=Ub2(iii,j)
8211         dipderj(iii)=Ub2der(iii,j)
8212         dipj(iii,2)=b1(iii,itj1)
8213       enddo
8214       kkk=0
8215       do iii=1,2
8216         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8217         do jjj=1,2
8218           kkk=kkk+1
8219           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8220         enddo
8221       enddo
8222       do kkk=1,5
8223         do lll=1,3
8224           mmm=0
8225           do iii=1,2
8226             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8227               auxvec(1))
8228             do jjj=1,2
8229               mmm=mmm+1
8230               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8231             enddo
8232           enddo
8233         enddo
8234       enddo
8235       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8236       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8237       do iii=1,2
8238         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8239       enddo
8240       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8241       do iii=1,2
8242         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8243       enddo
8244       return
8245       end subroutine dipole
8246 #endif
8247 !-----------------------------------------------------------------------------
8248       subroutine calc_eello(i,j,k,l,jj,kk)
8249 !
8250 ! This subroutine computes matrices and vectors needed to calculate
8251 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8252 !
8253       use comm_kut
8254 !      implicit real*8 (a-h,o-z)
8255 !      include 'DIMENSIONS'
8256 !      include 'COMMON.IOUNITS'
8257 !      include 'COMMON.CHAIN'
8258 !      include 'COMMON.DERIV'
8259 !      include 'COMMON.INTERACT'
8260 !      include 'COMMON.CONTACTS'
8261 !      include 'COMMON.TORSION'
8262 !      include 'COMMON.VAR'
8263 !      include 'COMMON.GEO'
8264 !      include 'COMMON.FFIELD'
8265       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8266       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8267       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8268               itj1
8269 !el      logical :: lprn
8270 !el      common /kutas/ lprn
8271 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8272 !d     & ' jj=',jj,' kk=',kk
8273 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8274 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8275 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8276       do iii=1,2
8277         do jjj=1,2
8278           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8279           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8280         enddo
8281       enddo
8282       call transpose2(aa1(1,1),aa1t(1,1))
8283       call transpose2(aa2(1,1),aa2t(1,1))
8284       do kkk=1,5
8285         do lll=1,3
8286           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8287             aa1tder(1,1,lll,kkk))
8288           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8289             aa2tder(1,1,lll,kkk))
8290         enddo
8291       enddo
8292       if (l.eq.j+1) then
8293 ! parallel orientation of the two CA-CA-CA frames.
8294         if (i.gt.1) then
8295           iti=itortyp(itype(i,1))
8296         else
8297           iti=ntortyp+1
8298         endif
8299         itk1=itortyp(itype(k+1,1))
8300         itj=itortyp(itype(j,1))
8301         if (l.lt.nres-1) then
8302           itl1=itortyp(itype(l+1,1))
8303         else
8304           itl1=ntortyp+1
8305         endif
8306 ! A1 kernel(j+1) A2T
8307 !d        do iii=1,2
8308 !d          write (iout,'(3f10.5,5x,3f10.5)')
8309 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8310 !d        enddo
8311         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8312          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8313          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8314 ! Following matrices are needed only for 6-th order cumulants
8315         IF (wcorr6.gt.0.0d0) THEN
8316         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8317          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8318          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8319         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8320          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8321          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8322          ADtEAderx(1,1,1,1,1,1))
8323         lprn=.false.
8324         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8325          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8326          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8327          ADtEA1derx(1,1,1,1,1,1))
8328         ENDIF
8329 ! End 6-th order cumulants
8330 !d        lprn=.false.
8331 !d        if (lprn) then
8332 !d        write (2,*) 'In calc_eello6'
8333 !d        do iii=1,2
8334 !d          write (2,*) 'iii=',iii
8335 !d          do kkk=1,5
8336 !d            write (2,*) 'kkk=',kkk
8337 !d            do jjj=1,2
8338 !d              write (2,'(3(2f10.5),5x)')
8339 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8340 !d            enddo
8341 !d          enddo
8342 !d        enddo
8343 !d        endif
8344         call transpose2(EUgder(1,1,k),auxmat(1,1))
8345         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8346         call transpose2(EUg(1,1,k),auxmat(1,1))
8347         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8348         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8349         do iii=1,2
8350           do kkk=1,5
8351             do lll=1,3
8352               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8353                 EAEAderx(1,1,lll,kkk,iii,1))
8354             enddo
8355           enddo
8356         enddo
8357 ! A1T kernel(i+1) A2
8358         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8359          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8360          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8361 ! Following matrices are needed only for 6-th order cumulants
8362         IF (wcorr6.gt.0.0d0) THEN
8363         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8364          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8365          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8366         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8367          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8368          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8369          ADtEAderx(1,1,1,1,1,2))
8370         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8371          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8372          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8373          ADtEA1derx(1,1,1,1,1,2))
8374         ENDIF
8375 ! End 6-th order cumulants
8376         call transpose2(EUgder(1,1,l),auxmat(1,1))
8377         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8378         call transpose2(EUg(1,1,l),auxmat(1,1))
8379         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8380         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8381         do iii=1,2
8382           do kkk=1,5
8383             do lll=1,3
8384               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8385                 EAEAderx(1,1,lll,kkk,iii,2))
8386             enddo
8387           enddo
8388         enddo
8389 ! AEAb1 and AEAb2
8390 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8391 ! They are needed only when the fifth- or the sixth-order cumulants are
8392 ! indluded.
8393         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8394         call transpose2(AEA(1,1,1),auxmat(1,1))
8395         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8396         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8397         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8398         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8399         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8400         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8401         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8402         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8403         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8404         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8405         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8406         call transpose2(AEA(1,1,2),auxmat(1,1))
8407         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8408         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8409         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8410         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8411         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8412         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8413         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8414         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8415         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8416         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8417         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8418 ! Calculate the Cartesian derivatives of the vectors.
8419         do iii=1,2
8420           do kkk=1,5
8421             do lll=1,3
8422               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8423               call matvec2(auxmat(1,1),b1(1,iti),&
8424                 AEAb1derx(1,lll,kkk,iii,1,1))
8425               call matvec2(auxmat(1,1),Ub2(1,i),&
8426                 AEAb2derx(1,lll,kkk,iii,1,1))
8427               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8428                 AEAb1derx(1,lll,kkk,iii,2,1))
8429               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8430                 AEAb2derx(1,lll,kkk,iii,2,1))
8431               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8432               call matvec2(auxmat(1,1),b1(1,itj),&
8433                 AEAb1derx(1,lll,kkk,iii,1,2))
8434               call matvec2(auxmat(1,1),Ub2(1,j),&
8435                 AEAb2derx(1,lll,kkk,iii,1,2))
8436               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8437                 AEAb1derx(1,lll,kkk,iii,2,2))
8438               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8439                 AEAb2derx(1,lll,kkk,iii,2,2))
8440             enddo
8441           enddo
8442         enddo
8443         ENDIF
8444 ! End vectors
8445       else
8446 ! Antiparallel orientation of the two CA-CA-CA frames.
8447         if (i.gt.1) then
8448           iti=itortyp(itype(i,1))
8449         else
8450           iti=ntortyp+1
8451         endif
8452         itk1=itortyp(itype(k+1,1))
8453         itl=itortyp(itype(l,1))
8454         itj=itortyp(itype(j,1))
8455         if (j.lt.nres-1) then
8456           itj1=itortyp(itype(j+1,1))
8457         else
8458           itj1=ntortyp+1
8459         endif
8460 ! A2 kernel(j-1)T A1T
8461         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8462          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8463          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8464 ! Following matrices are needed only for 6-th order cumulants
8465         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8466            j.eq.i+4 .and. l.eq.i+3)) THEN
8467         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8468          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8469          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8470         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8471          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8472          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8473          ADtEAderx(1,1,1,1,1,1))
8474         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8475          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8476          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8477          ADtEA1derx(1,1,1,1,1,1))
8478         ENDIF
8479 ! End 6-th order cumulants
8480         call transpose2(EUgder(1,1,k),auxmat(1,1))
8481         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8482         call transpose2(EUg(1,1,k),auxmat(1,1))
8483         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8484         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8485         do iii=1,2
8486           do kkk=1,5
8487             do lll=1,3
8488               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8489                 EAEAderx(1,1,lll,kkk,iii,1))
8490             enddo
8491           enddo
8492         enddo
8493 ! A2T kernel(i+1)T A1
8494         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8495          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8496          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8497 ! Following matrices are needed only for 6-th order cumulants
8498         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8499            j.eq.i+4 .and. l.eq.i+3)) THEN
8500         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8501          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8502          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8503         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8504          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8505          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8506          ADtEAderx(1,1,1,1,1,2))
8507         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8508          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8509          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8510          ADtEA1derx(1,1,1,1,1,2))
8511         ENDIF
8512 ! End 6-th order cumulants
8513         call transpose2(EUgder(1,1,j),auxmat(1,1))
8514         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8515         call transpose2(EUg(1,1,j),auxmat(1,1))
8516         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8517         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8518         do iii=1,2
8519           do kkk=1,5
8520             do lll=1,3
8521               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8522                 EAEAderx(1,1,lll,kkk,iii,2))
8523             enddo
8524           enddo
8525         enddo
8526 ! AEAb1 and AEAb2
8527 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8528 ! They are needed only when the fifth- or the sixth-order cumulants are
8529 ! indluded.
8530         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8531           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8532         call transpose2(AEA(1,1,1),auxmat(1,1))
8533         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8534         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8535         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8536         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8537         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8538         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8539         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8540         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8541         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8542         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8543         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8544         call transpose2(AEA(1,1,2),auxmat(1,1))
8545         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8546         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8547         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8548         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8549         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8550         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8551         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8552         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8553         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8554         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8555         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8556 ! Calculate the Cartesian derivatives of the vectors.
8557         do iii=1,2
8558           do kkk=1,5
8559             do lll=1,3
8560               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8561               call matvec2(auxmat(1,1),b1(1,iti),&
8562                 AEAb1derx(1,lll,kkk,iii,1,1))
8563               call matvec2(auxmat(1,1),Ub2(1,i),&
8564                 AEAb2derx(1,lll,kkk,iii,1,1))
8565               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8566                 AEAb1derx(1,lll,kkk,iii,2,1))
8567               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8568                 AEAb2derx(1,lll,kkk,iii,2,1))
8569               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8570               call matvec2(auxmat(1,1),b1(1,itl),&
8571                 AEAb1derx(1,lll,kkk,iii,1,2))
8572               call matvec2(auxmat(1,1),Ub2(1,l),&
8573                 AEAb2derx(1,lll,kkk,iii,1,2))
8574               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8575                 AEAb1derx(1,lll,kkk,iii,2,2))
8576               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8577                 AEAb2derx(1,lll,kkk,iii,2,2))
8578             enddo
8579           enddo
8580         enddo
8581         ENDIF
8582 ! End vectors
8583       endif
8584       return
8585       end subroutine calc_eello
8586 !-----------------------------------------------------------------------------
8587       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8588       use comm_kut
8589       implicit none
8590       integer :: nderg
8591       logical :: transp
8592       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8593       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8594       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8595       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8596       integer :: iii,kkk,lll
8597       integer :: jjj,mmm
8598 !el      logical :: lprn
8599 !el      common /kutas/ lprn
8600       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8601       do iii=1,nderg
8602         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8603           AKAderg(1,1,iii))
8604       enddo
8605 !d      if (lprn) write (2,*) 'In kernel'
8606       do kkk=1,5
8607 !d        if (lprn) write (2,*) 'kkk=',kkk
8608         do lll=1,3
8609           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8610             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8611 !d          if (lprn) then
8612 !d            write (2,*) 'lll=',lll
8613 !d            write (2,*) 'iii=1'
8614 !d            do jjj=1,2
8615 !d              write (2,'(3(2f10.5),5x)')
8616 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8617 !d            enddo
8618 !d          endif
8619           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8620             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8621 !d          if (lprn) then
8622 !d            write (2,*) 'lll=',lll
8623 !d            write (2,*) 'iii=2'
8624 !d            do jjj=1,2
8625 !d              write (2,'(3(2f10.5),5x)')
8626 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8627 !d            enddo
8628 !d          endif
8629         enddo
8630       enddo
8631       return
8632       end subroutine kernel
8633 !-----------------------------------------------------------------------------
8634       real(kind=8) function eello4(i,j,k,l,jj,kk)
8635 !      implicit real*8 (a-h,o-z)
8636 !      include 'DIMENSIONS'
8637 !      include 'COMMON.IOUNITS'
8638 !      include 'COMMON.CHAIN'
8639 !      include 'COMMON.DERIV'
8640 !      include 'COMMON.INTERACT'
8641 !      include 'COMMON.CONTACTS'
8642 !      include 'COMMON.TORSION'
8643 !      include 'COMMON.VAR'
8644 !      include 'COMMON.GEO'
8645       real(kind=8),dimension(2,2) :: pizda
8646       real(kind=8),dimension(3) :: ggg1,ggg2
8647       real(kind=8) ::  eel4,glongij,glongkl
8648       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8649 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8650 !d        eello4=0.0d0
8651 !d        return
8652 !d      endif
8653 !d      print *,'eello4:',i,j,k,l,jj,kk
8654 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8655 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8656 !old      eij=facont_hb(jj,i)
8657 !old      ekl=facont_hb(kk,k)
8658 !old      ekont=eij*ekl
8659       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8660 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8661       gcorr_loc(k-1)=gcorr_loc(k-1) &
8662          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8663       if (l.eq.j+1) then
8664         gcorr_loc(l-1)=gcorr_loc(l-1) &
8665            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8666       else
8667         gcorr_loc(j-1)=gcorr_loc(j-1) &
8668            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8669       endif
8670       do iii=1,2
8671         do kkk=1,5
8672           do lll=1,3
8673             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8674                               -EAEAderx(2,2,lll,kkk,iii,1)
8675 !d            derx(lll,kkk,iii)=0.0d0
8676           enddo
8677         enddo
8678       enddo
8679 !d      gcorr_loc(l-1)=0.0d0
8680 !d      gcorr_loc(j-1)=0.0d0
8681 !d      gcorr_loc(k-1)=0.0d0
8682 !d      eel4=1.0d0
8683 !d      write (iout,*)'Contacts have occurred for peptide groups',
8684 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8685 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8686       if (j.lt.nres-1) then
8687         j1=j+1
8688         j2=j-1
8689       else
8690         j1=j-1
8691         j2=j-2
8692       endif
8693       if (l.lt.nres-1) then
8694         l1=l+1
8695         l2=l-1
8696       else
8697         l1=l-1
8698         l2=l-2
8699       endif
8700       do ll=1,3
8701 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8702 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8703         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8704         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8705 !grad        ghalf=0.5d0*ggg1(ll)
8706         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8707         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8708         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8709         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8710         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8711         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8712 !grad        ghalf=0.5d0*ggg2(ll)
8713         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8714         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8715         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8716         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8717         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8718         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8719       enddo
8720 !grad      do m=i+1,j-1
8721 !grad        do ll=1,3
8722 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8723 !grad        enddo
8724 !grad      enddo
8725 !grad      do m=k+1,l-1
8726 !grad        do ll=1,3
8727 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8728 !grad        enddo
8729 !grad      enddo
8730 !grad      do m=i+2,j2
8731 !grad        do ll=1,3
8732 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8733 !grad        enddo
8734 !grad      enddo
8735 !grad      do m=k+2,l2
8736 !grad        do ll=1,3
8737 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8738 !grad        enddo
8739 !grad      enddo
8740 !d      do iii=1,nres-3
8741 !d        write (2,*) iii,gcorr_loc(iii)
8742 !d      enddo
8743       eello4=ekont*eel4
8744 !d      write (2,*) 'ekont',ekont
8745 !d      write (iout,*) 'eello4',ekont*eel4
8746       return
8747       end function eello4
8748 !-----------------------------------------------------------------------------
8749       real(kind=8) function eello5(i,j,k,l,jj,kk)
8750 !      implicit real*8 (a-h,o-z)
8751 !      include 'DIMENSIONS'
8752 !      include 'COMMON.IOUNITS'
8753 !      include 'COMMON.CHAIN'
8754 !      include 'COMMON.DERIV'
8755 !      include 'COMMON.INTERACT'
8756 !      include 'COMMON.CONTACTS'
8757 !      include 'COMMON.TORSION'
8758 !      include 'COMMON.VAR'
8759 !      include 'COMMON.GEO'
8760       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8761       real(kind=8),dimension(2) :: vv
8762       real(kind=8),dimension(3) :: ggg1,ggg2
8763       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8764       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8765       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8766 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8767 !                                                                              C
8768 !                            Parallel chains                                   C
8769 !                                                                              C
8770 !          o             o                   o             o                   C
8771 !         /l\           / \             \   / \           / \   /              C
8772 !        /   \         /   \             \ /   \         /   \ /               C
8773 !       j| o |l1       | o |                o| o |         | o |o                C
8774 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8775 !      \i/   \         /   \ /             /   \         /   \                 C
8776 !       o    k1             o                                                  C
8777 !         (I)          (II)                (III)          (IV)                 C
8778 !                                                                              C
8779 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8780 !                                                                              C
8781 !                            Antiparallel chains                               C
8782 !                                                                              C
8783 !          o             o                   o             o                   C
8784 !         /j\           / \             \   / \           / \   /              C
8785 !        /   \         /   \             \ /   \         /   \ /               C
8786 !      j1| o |l        | o |                o| o |         | o |o                C
8787 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8788 !      \i/   \         /   \ /             /   \         /   \                 C
8789 !       o     k1            o                                                  C
8790 !         (I)          (II)                (III)          (IV)                 C
8791 !                                                                              C
8792 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8793 !                                                                              C
8794 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8795 !                                                                              C
8796 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8797 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8798 !d        eello5=0.0d0
8799 !d        return
8800 !d      endif
8801 !d      write (iout,*)
8802 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8803 !d     &   ' and',k,l
8804       itk=itortyp(itype(k,1))
8805       itl=itortyp(itype(l,1))
8806       itj=itortyp(itype(j,1))
8807       eello5_1=0.0d0
8808       eello5_2=0.0d0
8809       eello5_3=0.0d0
8810       eello5_4=0.0d0
8811 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8812 !d     &   eel5_3_num,eel5_4_num)
8813       do iii=1,2
8814         do kkk=1,5
8815           do lll=1,3
8816             derx(lll,kkk,iii)=0.0d0
8817           enddo
8818         enddo
8819       enddo
8820 !d      eij=facont_hb(jj,i)
8821 !d      ekl=facont_hb(kk,k)
8822 !d      ekont=eij*ekl
8823 !d      write (iout,*)'Contacts have occurred for peptide groups',
8824 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8825 !d      goto 1111
8826 ! Contribution from the graph I.
8827 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8828 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8829       call transpose2(EUg(1,1,k),auxmat(1,1))
8830       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8831       vv(1)=pizda(1,1)-pizda(2,2)
8832       vv(2)=pizda(1,2)+pizda(2,1)
8833       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8834        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8835 ! Explicit gradient in virtual-dihedral angles.
8836       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8837        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8838        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8839       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8840       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8841       vv(1)=pizda(1,1)-pizda(2,2)
8842       vv(2)=pizda(1,2)+pizda(2,1)
8843       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8844        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8845        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8846       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8847       vv(1)=pizda(1,1)-pizda(2,2)
8848       vv(2)=pizda(1,2)+pizda(2,1)
8849       if (l.eq.j+1) then
8850         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8851          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8852          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8853       else
8854         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8855          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8856          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8857       endif
8858 ! Cartesian gradient
8859       do iii=1,2
8860         do kkk=1,5
8861           do lll=1,3
8862             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8863               pizda(1,1))
8864             vv(1)=pizda(1,1)-pizda(2,2)
8865             vv(2)=pizda(1,2)+pizda(2,1)
8866             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8867              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8868              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8869           enddo
8870         enddo
8871       enddo
8872 !      goto 1112
8873 !1111  continue
8874 ! Contribution from graph II
8875       call transpose2(EE(1,1,itk),auxmat(1,1))
8876       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8877       vv(1)=pizda(1,1)+pizda(2,2)
8878       vv(2)=pizda(2,1)-pizda(1,2)
8879       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8880        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8881 ! Explicit gradient in virtual-dihedral angles.
8882       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8883        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8884       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8885       vv(1)=pizda(1,1)+pizda(2,2)
8886       vv(2)=pizda(2,1)-pizda(1,2)
8887       if (l.eq.j+1) then
8888         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8889          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8890          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8891       else
8892         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8893          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8894          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8895       endif
8896 ! Cartesian gradient
8897       do iii=1,2
8898         do kkk=1,5
8899           do lll=1,3
8900             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8901               pizda(1,1))
8902             vv(1)=pizda(1,1)+pizda(2,2)
8903             vv(2)=pizda(2,1)-pizda(1,2)
8904             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8905              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8906              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8907           enddo
8908         enddo
8909       enddo
8910 !d      goto 1112
8911 !d1111  continue
8912       if (l.eq.j+1) then
8913 !d        goto 1110
8914 ! Parallel orientation
8915 ! Contribution from graph III
8916         call transpose2(EUg(1,1,l),auxmat(1,1))
8917         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8918         vv(1)=pizda(1,1)-pizda(2,2)
8919         vv(2)=pizda(1,2)+pizda(2,1)
8920         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8921          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8922 ! Explicit gradient in virtual-dihedral angles.
8923         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8924          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8925          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8926         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8927         vv(1)=pizda(1,1)-pizda(2,2)
8928         vv(2)=pizda(1,2)+pizda(2,1)
8929         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8930          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8931          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8932         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8933         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8934         vv(1)=pizda(1,1)-pizda(2,2)
8935         vv(2)=pizda(1,2)+pizda(2,1)
8936         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8937          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8938          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8939 ! Cartesian gradient
8940         do iii=1,2
8941           do kkk=1,5
8942             do lll=1,3
8943               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8944                 pizda(1,1))
8945               vv(1)=pizda(1,1)-pizda(2,2)
8946               vv(2)=pizda(1,2)+pizda(2,1)
8947               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8948                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8949                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8950             enddo
8951           enddo
8952         enddo
8953 !d        goto 1112
8954 ! Contribution from graph IV
8955 !d1110    continue
8956         call transpose2(EE(1,1,itl),auxmat(1,1))
8957         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8958         vv(1)=pizda(1,1)+pizda(2,2)
8959         vv(2)=pizda(2,1)-pizda(1,2)
8960         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8961          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8962 ! Explicit gradient in virtual-dihedral angles.
8963         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8964          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8965         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8966         vv(1)=pizda(1,1)+pizda(2,2)
8967         vv(2)=pizda(2,1)-pizda(1,2)
8968         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8969          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8970          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8971 ! Cartesian gradient
8972         do iii=1,2
8973           do kkk=1,5
8974             do lll=1,3
8975               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8976                 pizda(1,1))
8977               vv(1)=pizda(1,1)+pizda(2,2)
8978               vv(2)=pizda(2,1)-pizda(1,2)
8979               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8980                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8981                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8982             enddo
8983           enddo
8984         enddo
8985       else
8986 ! Antiparallel orientation
8987 ! Contribution from graph III
8988 !        goto 1110
8989         call transpose2(EUg(1,1,j),auxmat(1,1))
8990         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8991         vv(1)=pizda(1,1)-pizda(2,2)
8992         vv(2)=pizda(1,2)+pizda(2,1)
8993         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8994          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8995 ! Explicit gradient in virtual-dihedral angles.
8996         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8997          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8998          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8999         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9000         vv(1)=pizda(1,1)-pizda(2,2)
9001         vv(2)=pizda(1,2)+pizda(2,1)
9002         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9003          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9004          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9005         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9006         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9007         vv(1)=pizda(1,1)-pizda(2,2)
9008         vv(2)=pizda(1,2)+pizda(2,1)
9009         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9010          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9011          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9012 ! Cartesian gradient
9013         do iii=1,2
9014           do kkk=1,5
9015             do lll=1,3
9016               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9017                 pizda(1,1))
9018               vv(1)=pizda(1,1)-pizda(2,2)
9019               vv(2)=pizda(1,2)+pizda(2,1)
9020               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9021                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9022                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9023             enddo
9024           enddo
9025         enddo
9026 !d        goto 1112
9027 ! Contribution from graph IV
9028 1110    continue
9029         call transpose2(EE(1,1,itj),auxmat(1,1))
9030         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9031         vv(1)=pizda(1,1)+pizda(2,2)
9032         vv(2)=pizda(2,1)-pizda(1,2)
9033         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9034          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9035 ! Explicit gradient in virtual-dihedral angles.
9036         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9037          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9038         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9039         vv(1)=pizda(1,1)+pizda(2,2)
9040         vv(2)=pizda(2,1)-pizda(1,2)
9041         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9042          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9043          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9044 ! Cartesian gradient
9045         do iii=1,2
9046           do kkk=1,5
9047             do lll=1,3
9048               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9049                 pizda(1,1))
9050               vv(1)=pizda(1,1)+pizda(2,2)
9051               vv(2)=pizda(2,1)-pizda(1,2)
9052               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9053                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9054                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9055             enddo
9056           enddo
9057         enddo
9058       endif
9059 1112  continue
9060       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9061 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9062 !d        write (2,*) 'ijkl',i,j,k,l
9063 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9064 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9065 !d      endif
9066 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9067 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9068 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9069 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9070       if (j.lt.nres-1) then
9071         j1=j+1
9072         j2=j-1
9073       else
9074         j1=j-1
9075         j2=j-2
9076       endif
9077       if (l.lt.nres-1) then
9078         l1=l+1
9079         l2=l-1
9080       else
9081         l1=l-1
9082         l2=l-2
9083       endif
9084 !d      eij=1.0d0
9085 !d      ekl=1.0d0
9086 !d      ekont=1.0d0
9087 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9088 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9089 !        summed up outside the subrouine as for the other subroutines
9090 !        handling long-range interactions. The old code is commented out
9091 !        with "cgrad" to keep track of changes.
9092       do ll=1,3
9093 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9094 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9095         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9096         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9097 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9098 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9099 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9100 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9101 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9102 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9103 !     &   gradcorr5ij,
9104 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9105 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9106 !grad        ghalf=0.5d0*ggg1(ll)
9107 !d        ghalf=0.0d0
9108         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9109         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9110         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9111         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9112         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9113         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9114 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9115 !grad        ghalf=0.5d0*ggg2(ll)
9116         ghalf=0.0d0
9117         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9118         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9119         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9120         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9121         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9122         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9123       enddo
9124 !d      goto 1112
9125 !grad      do m=i+1,j-1
9126 !grad        do ll=1,3
9127 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9128 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9129 !grad        enddo
9130 !grad      enddo
9131 !grad      do m=k+1,l-1
9132 !grad        do ll=1,3
9133 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9134 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9135 !grad        enddo
9136 !grad      enddo
9137 !1112  continue
9138 !grad      do m=i+2,j2
9139 !grad        do ll=1,3
9140 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9141 !grad        enddo
9142 !grad      enddo
9143 !grad      do m=k+2,l2
9144 !grad        do ll=1,3
9145 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9146 !grad        enddo
9147 !grad      enddo
9148 !d      do iii=1,nres-3
9149 !d        write (2,*) iii,g_corr5_loc(iii)
9150 !d      enddo
9151       eello5=ekont*eel5
9152 !d      write (2,*) 'ekont',ekont
9153 !d      write (iout,*) 'eello5',ekont*eel5
9154       return
9155       end function eello5
9156 !-----------------------------------------------------------------------------
9157       real(kind=8) function eello6(i,j,k,l,jj,kk)
9158 !      implicit real*8 (a-h,o-z)
9159 !      include 'DIMENSIONS'
9160 !      include 'COMMON.IOUNITS'
9161 !      include 'COMMON.CHAIN'
9162 !      include 'COMMON.DERIV'
9163 !      include 'COMMON.INTERACT'
9164 !      include 'COMMON.CONTACTS'
9165 !      include 'COMMON.TORSION'
9166 !      include 'COMMON.VAR'
9167 !      include 'COMMON.GEO'
9168 !      include 'COMMON.FFIELD'
9169       real(kind=8),dimension(3) :: ggg1,ggg2
9170       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9171                    eello6_6,eel6
9172       real(kind=8) :: gradcorr6ij,gradcorr6kl
9173       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9174 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9175 !d        eello6=0.0d0
9176 !d        return
9177 !d      endif
9178 !d      write (iout,*)
9179 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9180 !d     &   ' and',k,l
9181       eello6_1=0.0d0
9182       eello6_2=0.0d0
9183       eello6_3=0.0d0
9184       eello6_4=0.0d0
9185       eello6_5=0.0d0
9186       eello6_6=0.0d0
9187 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9188 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9189       do iii=1,2
9190         do kkk=1,5
9191           do lll=1,3
9192             derx(lll,kkk,iii)=0.0d0
9193           enddo
9194         enddo
9195       enddo
9196 !d      eij=facont_hb(jj,i)
9197 !d      ekl=facont_hb(kk,k)
9198 !d      ekont=eij*ekl
9199 !d      eij=1.0d0
9200 !d      ekl=1.0d0
9201 !d      ekont=1.0d0
9202       if (l.eq.j+1) then
9203         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9204         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9205         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9206         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9207         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9208         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9209       else
9210         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9211         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9212         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9213         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9214         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9215           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9216         else
9217           eello6_5=0.0d0
9218         endif
9219         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9220       endif
9221 ! If turn contributions are considered, they will be handled separately.
9222       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9223 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9224 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9225 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9226 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9227 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9228 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9229 !d      goto 1112
9230       if (j.lt.nres-1) then
9231         j1=j+1
9232         j2=j-1
9233       else
9234         j1=j-1
9235         j2=j-2
9236       endif
9237       if (l.lt.nres-1) then
9238         l1=l+1
9239         l2=l-1
9240       else
9241         l1=l-1
9242         l2=l-2
9243       endif
9244       do ll=1,3
9245 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9246 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9247 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9248 !grad        ghalf=0.5d0*ggg1(ll)
9249 !d        ghalf=0.0d0
9250         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9251         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9252         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9253         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9254         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9255         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9256         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9257         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9258 !grad        ghalf=0.5d0*ggg2(ll)
9259 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9260 !d        ghalf=0.0d0
9261         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9262         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9263         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9264         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9265         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9266         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9267       enddo
9268 !d      goto 1112
9269 !grad      do m=i+1,j-1
9270 !grad        do ll=1,3
9271 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9272 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9273 !grad        enddo
9274 !grad      enddo
9275 !grad      do m=k+1,l-1
9276 !grad        do ll=1,3
9277 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9278 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9279 !grad        enddo
9280 !grad      enddo
9281 !grad1112  continue
9282 !grad      do m=i+2,j2
9283 !grad        do ll=1,3
9284 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9285 !grad        enddo
9286 !grad      enddo
9287 !grad      do m=k+2,l2
9288 !grad        do ll=1,3
9289 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9290 !grad        enddo
9291 !grad      enddo
9292 !d      do iii=1,nres-3
9293 !d        write (2,*) iii,g_corr6_loc(iii)
9294 !d      enddo
9295       eello6=ekont*eel6
9296 !d      write (2,*) 'ekont',ekont
9297 !d      write (iout,*) 'eello6',ekont*eel6
9298       return
9299       end function eello6
9300 !-----------------------------------------------------------------------------
9301       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9302       use comm_kut
9303 !      implicit real*8 (a-h,o-z)
9304 !      include 'DIMENSIONS'
9305 !      include 'COMMON.IOUNITS'
9306 !      include 'COMMON.CHAIN'
9307 !      include 'COMMON.DERIV'
9308 !      include 'COMMON.INTERACT'
9309 !      include 'COMMON.CONTACTS'
9310 !      include 'COMMON.TORSION'
9311 !      include 'COMMON.VAR'
9312 !      include 'COMMON.GEO'
9313       real(kind=8),dimension(2) :: vv,vv1
9314       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9315       logical :: swap
9316 !el      logical :: lprn
9317 !el      common /kutas/ lprn
9318       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9319       real(kind=8) :: s1,s2,s3,s4,s5
9320 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9321 !                                                                              C
9322 !      Parallel       Antiparallel                                             C
9323 !                                                                              C
9324 !          o             o                                                     C
9325 !         /l\           /j\                                                    C
9326 !        /   \         /   \                                                   C
9327 !       /| o |         | o |\                                                  C
9328 !     \ j|/k\|  /   \  |/k\|l /                                                C
9329 !      \ /   \ /     \ /   \ /                                                 C
9330 !       o     o       o     o                                                  C
9331 !       i             i                                                        C
9332 !                                                                              C
9333 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9334       itk=itortyp(itype(k,1))
9335       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9336       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9337       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9338       call transpose2(EUgC(1,1,k),auxmat(1,1))
9339       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9340       vv1(1)=pizda1(1,1)-pizda1(2,2)
9341       vv1(2)=pizda1(1,2)+pizda1(2,1)
9342       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9343       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9344       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9345       s5=scalar2(vv(1),Dtobr2(1,i))
9346 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9347       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9348       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9349        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9350        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9351        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9352        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9353        +scalar2(vv(1),Dtobr2der(1,i)))
9354       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9355       vv1(1)=pizda1(1,1)-pizda1(2,2)
9356       vv1(2)=pizda1(1,2)+pizda1(2,1)
9357       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9358       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9359       if (l.eq.j+1) then
9360         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9361        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9362        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9363        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9364        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9365       else
9366         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9367        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9368        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9369        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9370        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9371       endif
9372       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9373       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9374       vv1(1)=pizda1(1,1)-pizda1(2,2)
9375       vv1(2)=pizda1(1,2)+pizda1(2,1)
9376       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9377        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9378        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9379        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9380       do iii=1,2
9381         if (swap) then
9382           ind=3-iii
9383         else
9384           ind=iii
9385         endif
9386         do kkk=1,5
9387           do lll=1,3
9388             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9389             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9390             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9391             call transpose2(EUgC(1,1,k),auxmat(1,1))
9392             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9393               pizda1(1,1))
9394             vv1(1)=pizda1(1,1)-pizda1(2,2)
9395             vv1(2)=pizda1(1,2)+pizda1(2,1)
9396             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9397             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9398              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9399             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9400              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9401             s5=scalar2(vv(1),Dtobr2(1,i))
9402             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9403           enddo
9404         enddo
9405       enddo
9406       return
9407       end function eello6_graph1
9408 !-----------------------------------------------------------------------------
9409       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9410       use comm_kut
9411 !      implicit real*8 (a-h,o-z)
9412 !      include 'DIMENSIONS'
9413 !      include 'COMMON.IOUNITS'
9414 !      include 'COMMON.CHAIN'
9415 !      include 'COMMON.DERIV'
9416 !      include 'COMMON.INTERACT'
9417 !      include 'COMMON.CONTACTS'
9418 !      include 'COMMON.TORSION'
9419 !      include 'COMMON.VAR'
9420 !      include 'COMMON.GEO'
9421       logical :: swap
9422       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9423       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9424 !el      logical :: lprn
9425 !el      common /kutas/ lprn
9426       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9427       real(kind=8) :: s2,s3,s4
9428 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9429 !                                                                              C
9430 !      Parallel       Antiparallel                                             C
9431 !                                                                              C
9432 !          o             o                                                     C
9433 !     \   /l\           /j\   /                                                C
9434 !      \ /   \         /   \ /                                                 C
9435 !       o| o |         | o |o                                                  C
9436 !     \ j|/k\|      \  |/k\|l                                                  C
9437 !      \ /   \       \ /   \                                                   C
9438 !       o             o                                                        C
9439 !       i             i                                                        C
9440 !                                                                              C
9441 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9442 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9443 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9444 !           but not in a cluster cumulant
9445 #ifdef MOMENT
9446       s1=dip(1,jj,i)*dip(1,kk,k)
9447 #endif
9448       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9449       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9450       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9451       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9452       call transpose2(EUg(1,1,k),auxmat(1,1))
9453       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9454       vv(1)=pizda(1,1)-pizda(2,2)
9455       vv(2)=pizda(1,2)+pizda(2,1)
9456       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9457 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9458 #ifdef MOMENT
9459       eello6_graph2=-(s1+s2+s3+s4)
9460 #else
9461       eello6_graph2=-(s2+s3+s4)
9462 #endif
9463 !      eello6_graph2=-s3
9464 ! Derivatives in gamma(i-1)
9465       if (i.gt.1) then
9466 #ifdef MOMENT
9467         s1=dipderg(1,jj,i)*dip(1,kk,k)
9468 #endif
9469         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9470         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9471         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9472         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9473 #ifdef MOMENT
9474         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9475 #else
9476         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9477 #endif
9478 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9479       endif
9480 ! Derivatives in gamma(k-1)
9481 #ifdef MOMENT
9482       s1=dip(1,jj,i)*dipderg(1,kk,k)
9483 #endif
9484       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9485       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9486       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9487       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9488       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9489       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9490       vv(1)=pizda(1,1)-pizda(2,2)
9491       vv(2)=pizda(1,2)+pizda(2,1)
9492       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9493 #ifdef MOMENT
9494       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9495 #else
9496       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9497 #endif
9498 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9499 ! Derivatives in gamma(j-1) or gamma(l-1)
9500       if (j.gt.1) then
9501 #ifdef MOMENT
9502         s1=dipderg(3,jj,i)*dip(1,kk,k)
9503 #endif
9504         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9505         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9506         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9507         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9508         vv(1)=pizda(1,1)-pizda(2,2)
9509         vv(2)=pizda(1,2)+pizda(2,1)
9510         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9511 #ifdef MOMENT
9512         if (swap) then
9513           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9514         else
9515           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9516         endif
9517 #endif
9518         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9519 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9520       endif
9521 ! Derivatives in gamma(l-1) or gamma(j-1)
9522       if (l.gt.1) then
9523 #ifdef MOMENT
9524         s1=dip(1,jj,i)*dipderg(3,kk,k)
9525 #endif
9526         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9527         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9528         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9529         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9530         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9531         vv(1)=pizda(1,1)-pizda(2,2)
9532         vv(2)=pizda(1,2)+pizda(2,1)
9533         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9534 #ifdef MOMENT
9535         if (swap) then
9536           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9537         else
9538           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9539         endif
9540 #endif
9541         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9542 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9543       endif
9544 ! Cartesian derivatives.
9545       if (lprn) then
9546         write (2,*) 'In eello6_graph2'
9547         do iii=1,2
9548           write (2,*) 'iii=',iii
9549           do kkk=1,5
9550             write (2,*) 'kkk=',kkk
9551             do jjj=1,2
9552               write (2,'(3(2f10.5),5x)') &
9553               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9554             enddo
9555           enddo
9556         enddo
9557       endif
9558       do iii=1,2
9559         do kkk=1,5
9560           do lll=1,3
9561 #ifdef MOMENT
9562             if (iii.eq.1) then
9563               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9564             else
9565               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9566             endif
9567 #endif
9568             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9569               auxvec(1))
9570             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9571             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9572               auxvec(1))
9573             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9574             call transpose2(EUg(1,1,k),auxmat(1,1))
9575             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9576               pizda(1,1))
9577             vv(1)=pizda(1,1)-pizda(2,2)
9578             vv(2)=pizda(1,2)+pizda(2,1)
9579             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9580 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9581 #ifdef MOMENT
9582             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9583 #else
9584             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9585 #endif
9586             if (swap) then
9587               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9588             else
9589               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9590             endif
9591           enddo
9592         enddo
9593       enddo
9594       return
9595       end function eello6_graph2
9596 !-----------------------------------------------------------------------------
9597       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9598 !      implicit real*8 (a-h,o-z)
9599 !      include 'DIMENSIONS'
9600 !      include 'COMMON.IOUNITS'
9601 !      include 'COMMON.CHAIN'
9602 !      include 'COMMON.DERIV'
9603 !      include 'COMMON.INTERACT'
9604 !      include 'COMMON.CONTACTS'
9605 !      include 'COMMON.TORSION'
9606 !      include 'COMMON.VAR'
9607 !      include 'COMMON.GEO'
9608       real(kind=8),dimension(2) :: vv,auxvec
9609       real(kind=8),dimension(2,2) :: pizda,auxmat
9610       logical :: swap
9611       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9612       real(kind=8) :: s1,s2,s3,s4
9613 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9614 !                                                                              C
9615 !      Parallel       Antiparallel                                             C
9616 !                                                                              C
9617 !          o             o                                                     C
9618 !         /l\   /   \   /j\                                                    C
9619 !        /   \ /     \ /   \                                                   C
9620 !       /| o |o       o| o |\                                                  C
9621 !       j|/k\|  /      |/k\|l /                                                C
9622 !        /   \ /       /   \ /                                                 C
9623 !       /     o       /     o                                                  C
9624 !       i             i                                                        C
9625 !                                                                              C
9626 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9627 !
9628 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9629 !           energy moment and not to the cluster cumulant.
9630       iti=itortyp(itype(i,1))
9631       if (j.lt.nres-1) then
9632         itj1=itortyp(itype(j+1,1))
9633       else
9634         itj1=ntortyp+1
9635       endif
9636       itk=itortyp(itype(k,1))
9637       itk1=itortyp(itype(k+1,1))
9638       if (l.lt.nres-1) then
9639         itl1=itortyp(itype(l+1,1))
9640       else
9641         itl1=ntortyp+1
9642       endif
9643 #ifdef MOMENT
9644       s1=dip(4,jj,i)*dip(4,kk,k)
9645 #endif
9646       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9647       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9648       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9649       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9650       call transpose2(EE(1,1,itk),auxmat(1,1))
9651       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9652       vv(1)=pizda(1,1)+pizda(2,2)
9653       vv(2)=pizda(2,1)-pizda(1,2)
9654       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9655 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9656 !d     & "sum",-(s2+s3+s4)
9657 #ifdef MOMENT
9658       eello6_graph3=-(s1+s2+s3+s4)
9659 #else
9660       eello6_graph3=-(s2+s3+s4)
9661 #endif
9662 !      eello6_graph3=-s4
9663 ! Derivatives in gamma(k-1)
9664       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9665       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9666       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9667       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9668 ! Derivatives in gamma(l-1)
9669       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9670       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9671       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9672       vv(1)=pizda(1,1)+pizda(2,2)
9673       vv(2)=pizda(2,1)-pizda(1,2)
9674       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9675       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9676 ! Cartesian derivatives.
9677       do iii=1,2
9678         do kkk=1,5
9679           do lll=1,3
9680 #ifdef MOMENT
9681             if (iii.eq.1) then
9682               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9683             else
9684               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9685             endif
9686 #endif
9687             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9688               auxvec(1))
9689             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9690             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9691               auxvec(1))
9692             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9693             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9694               pizda(1,1))
9695             vv(1)=pizda(1,1)+pizda(2,2)
9696             vv(2)=pizda(2,1)-pizda(1,2)
9697             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9698 #ifdef MOMENT
9699             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9700 #else
9701             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9702 #endif
9703             if (swap) then
9704               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9705             else
9706               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9707             endif
9708 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9709           enddo
9710         enddo
9711       enddo
9712       return
9713       end function eello6_graph3
9714 !-----------------------------------------------------------------------------
9715       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9716 !      implicit real*8 (a-h,o-z)
9717 !      include 'DIMENSIONS'
9718 !      include 'COMMON.IOUNITS'
9719 !      include 'COMMON.CHAIN'
9720 !      include 'COMMON.DERIV'
9721 !      include 'COMMON.INTERACT'
9722 !      include 'COMMON.CONTACTS'
9723 !      include 'COMMON.TORSION'
9724 !      include 'COMMON.VAR'
9725 !      include 'COMMON.GEO'
9726 !      include 'COMMON.FFIELD'
9727       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9728       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9729       logical :: swap
9730       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9731               iii,kkk,lll
9732       real(kind=8) :: s1,s2,s3,s4
9733 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9734 !                                                                              C
9735 !      Parallel       Antiparallel                                             C
9736 !                                                                              C
9737 !          o             o                                                     C
9738 !         /l\   /   \   /j\                                                    C
9739 !        /   \ /     \ /   \                                                   C
9740 !       /| o |o       o| o |\                                                  C
9741 !     \ j|/k\|      \  |/k\|l                                                  C
9742 !      \ /   \       \ /   \                                                   C
9743 !       o     \       o     \                                                  C
9744 !       i             i                                                        C
9745 !                                                                              C
9746 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9747 !
9748 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9749 !           energy moment and not to the cluster cumulant.
9750 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9751       iti=itortyp(itype(i,1))
9752       itj=itortyp(itype(j,1))
9753       if (j.lt.nres-1) then
9754         itj1=itortyp(itype(j+1,1))
9755       else
9756         itj1=ntortyp+1
9757       endif
9758       itk=itortyp(itype(k,1))
9759       if (k.lt.nres-1) then
9760         itk1=itortyp(itype(k+1,1))
9761       else
9762         itk1=ntortyp+1
9763       endif
9764       itl=itortyp(itype(l,1))
9765       if (l.lt.nres-1) then
9766         itl1=itortyp(itype(l+1,1))
9767       else
9768         itl1=ntortyp+1
9769       endif
9770 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9771 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9772 !d     & ' itl',itl,' itl1',itl1
9773 #ifdef MOMENT
9774       if (imat.eq.1) then
9775         s1=dip(3,jj,i)*dip(3,kk,k)
9776       else
9777         s1=dip(2,jj,j)*dip(2,kk,l)
9778       endif
9779 #endif
9780       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9781       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9782       if (j.eq.l+1) then
9783         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9784         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9785       else
9786         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9787         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9788       endif
9789       call transpose2(EUg(1,1,k),auxmat(1,1))
9790       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9791       vv(1)=pizda(1,1)-pizda(2,2)
9792       vv(2)=pizda(2,1)+pizda(1,2)
9793       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9794 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9795 #ifdef MOMENT
9796       eello6_graph4=-(s1+s2+s3+s4)
9797 #else
9798       eello6_graph4=-(s2+s3+s4)
9799 #endif
9800 ! Derivatives in gamma(i-1)
9801       if (i.gt.1) then
9802 #ifdef MOMENT
9803         if (imat.eq.1) then
9804           s1=dipderg(2,jj,i)*dip(3,kk,k)
9805         else
9806           s1=dipderg(4,jj,j)*dip(2,kk,l)
9807         endif
9808 #endif
9809         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9810         if (j.eq.l+1) then
9811           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9812           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9813         else
9814           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9815           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9816         endif
9817         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9818         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9819 !d          write (2,*) 'turn6 derivatives'
9820 #ifdef MOMENT
9821           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9822 #else
9823           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9824 #endif
9825         else
9826 #ifdef MOMENT
9827           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9828 #else
9829           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9830 #endif
9831         endif
9832       endif
9833 ! Derivatives in gamma(k-1)
9834 #ifdef MOMENT
9835       if (imat.eq.1) then
9836         s1=dip(3,jj,i)*dipderg(2,kk,k)
9837       else
9838         s1=dip(2,jj,j)*dipderg(4,kk,l)
9839       endif
9840 #endif
9841       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9842       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9843       if (j.eq.l+1) then
9844         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9845         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9846       else
9847         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9848         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9849       endif
9850       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9851       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9852       vv(1)=pizda(1,1)-pizda(2,2)
9853       vv(2)=pizda(2,1)+pizda(1,2)
9854       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9855       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9856 #ifdef MOMENT
9857         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9858 #else
9859         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9860 #endif
9861       else
9862 #ifdef MOMENT
9863         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9864 #else
9865         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9866 #endif
9867       endif
9868 ! Derivatives in gamma(j-1) or gamma(l-1)
9869       if (l.eq.j+1 .and. l.gt.1) then
9870         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9871         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9872         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9873         vv(1)=pizda(1,1)-pizda(2,2)
9874         vv(2)=pizda(2,1)+pizda(1,2)
9875         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9876         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9877       else if (j.gt.1) then
9878         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9879         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9880         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9881         vv(1)=pizda(1,1)-pizda(2,2)
9882         vv(2)=pizda(2,1)+pizda(1,2)
9883         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9884         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9885           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9886         else
9887           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9888         endif
9889       endif
9890 ! Cartesian derivatives.
9891       do iii=1,2
9892         do kkk=1,5
9893           do lll=1,3
9894 #ifdef MOMENT
9895             if (iii.eq.1) then
9896               if (imat.eq.1) then
9897                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9898               else
9899                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9900               endif
9901             else
9902               if (imat.eq.1) then
9903                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9904               else
9905                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9906               endif
9907             endif
9908 #endif
9909             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9910               auxvec(1))
9911             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9912             if (j.eq.l+1) then
9913               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9914                 b1(1,itj1),auxvec(1))
9915               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9916             else
9917               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9918                 b1(1,itl1),auxvec(1))
9919               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9920             endif
9921             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9922               pizda(1,1))
9923             vv(1)=pizda(1,1)-pizda(2,2)
9924             vv(2)=pizda(2,1)+pizda(1,2)
9925             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9926             if (swap) then
9927               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9928 #ifdef MOMENT
9929                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9930                    -(s1+s2+s4)
9931 #else
9932                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9933                    -(s2+s4)
9934 #endif
9935                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9936               else
9937 #ifdef MOMENT
9938                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9939 #else
9940                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9941 #endif
9942                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9943               endif
9944             else
9945 #ifdef MOMENT
9946               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9947 #else
9948               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9949 #endif
9950               if (l.eq.j+1) then
9951                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9952               else
9953                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9954               endif
9955             endif
9956           enddo
9957         enddo
9958       enddo
9959       return
9960       end function eello6_graph4
9961 !-----------------------------------------------------------------------------
9962       real(kind=8) function eello_turn6(i,jj,kk)
9963 !      implicit real*8 (a-h,o-z)
9964 !      include 'DIMENSIONS'
9965 !      include 'COMMON.IOUNITS'
9966 !      include 'COMMON.CHAIN'
9967 !      include 'COMMON.DERIV'
9968 !      include 'COMMON.INTERACT'
9969 !      include 'COMMON.CONTACTS'
9970 !      include 'COMMON.TORSION'
9971 !      include 'COMMON.VAR'
9972 !      include 'COMMON.GEO'
9973       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9974       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9975       real(kind=8),dimension(3) :: ggg1,ggg2
9976       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9977       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9978 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9979 !           the respective energy moment and not to the cluster cumulant.
9980 !el local variables
9981       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9982       integer :: j1,j2,l1,l2,ll
9983       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9984       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9985       s1=0.0d0
9986       s8=0.0d0
9987       s13=0.0d0
9988 !
9989       eello_turn6=0.0d0
9990       j=i+4
9991       k=i+1
9992       l=i+3
9993       iti=itortyp(itype(i,1))
9994       itk=itortyp(itype(k,1))
9995       itk1=itortyp(itype(k+1,1))
9996       itl=itortyp(itype(l,1))
9997       itj=itortyp(itype(j,1))
9998 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9999 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10000 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10001 !d        eello6=0.0d0
10002 !d        return
10003 !d      endif
10004 !d      write (iout,*)
10005 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10006 !d     &   ' and',k,l
10007 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10008       do iii=1,2
10009         do kkk=1,5
10010           do lll=1,3
10011             derx_turn(lll,kkk,iii)=0.0d0
10012           enddo
10013         enddo
10014       enddo
10015 !d      eij=1.0d0
10016 !d      ekl=1.0d0
10017 !d      ekont=1.0d0
10018       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10019 !d      eello6_5=0.0d0
10020 !d      write (2,*) 'eello6_5',eello6_5
10021 #ifdef MOMENT
10022       call transpose2(AEA(1,1,1),auxmat(1,1))
10023       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10024       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10025       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10026 #endif
10027       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10028       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10029       s2 = scalar2(b1(1,itk),vtemp1(1))
10030 #ifdef MOMENT
10031       call transpose2(AEA(1,1,2),atemp(1,1))
10032       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10033       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10034       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10035 #endif
10036       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10037       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10038       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10039 #ifdef MOMENT
10040       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10041       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10042       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10043       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10044       ss13 = scalar2(b1(1,itk),vtemp4(1))
10045       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10046 #endif
10047 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10048 !      s1=0.0d0
10049 !      s2=0.0d0
10050 !      s8=0.0d0
10051 !      s12=0.0d0
10052 !      s13=0.0d0
10053       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10054 ! Derivatives in gamma(i+2)
10055       s1d =0.0d0
10056       s8d =0.0d0
10057 #ifdef MOMENT
10058       call transpose2(AEA(1,1,1),auxmatd(1,1))
10059       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10060       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10061       call transpose2(AEAderg(1,1,2),atempd(1,1))
10062       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10063       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10064 #endif
10065       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10066       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10067       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10068 !      s1d=0.0d0
10069 !      s2d=0.0d0
10070 !      s8d=0.0d0
10071 !      s12d=0.0d0
10072 !      s13d=0.0d0
10073       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10074 ! Derivatives in gamma(i+3)
10075 #ifdef MOMENT
10076       call transpose2(AEA(1,1,1),auxmatd(1,1))
10077       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10078       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10079       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10080 #endif
10081       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10082       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10083       s2d = scalar2(b1(1,itk),vtemp1d(1))
10084 #ifdef MOMENT
10085       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10086       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10087 #endif
10088       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10089 #ifdef MOMENT
10090       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10091       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10092       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10093 #endif
10094 !      s1d=0.0d0
10095 !      s2d=0.0d0
10096 !      s8d=0.0d0
10097 !      s12d=0.0d0
10098 !      s13d=0.0d0
10099 #ifdef MOMENT
10100       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10101                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10102 #else
10103       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10104                     -0.5d0*ekont*(s2d+s12d)
10105 #endif
10106 ! Derivatives in gamma(i+4)
10107       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10108       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10109       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10110 #ifdef MOMENT
10111       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10112       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10113       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10114 #endif
10115 !      s1d=0.0d0
10116 !      s2d=0.0d0
10117 !      s8d=0.0d0
10118 !      s12d=0.0d0
10119 !      s13d=0.0d0
10120 #ifdef MOMENT
10121       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10122 #else
10123       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10124 #endif
10125 ! Derivatives in gamma(i+5)
10126 #ifdef MOMENT
10127       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10128       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10129       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10130 #endif
10131       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10132       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10133       s2d = scalar2(b1(1,itk),vtemp1d(1))
10134 #ifdef MOMENT
10135       call transpose2(AEA(1,1,2),atempd(1,1))
10136       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10137       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10138 #endif
10139       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10140       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10141 #ifdef MOMENT
10142       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10143       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10144       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10145 #endif
10146 !      s1d=0.0d0
10147 !      s2d=0.0d0
10148 !      s8d=0.0d0
10149 !      s12d=0.0d0
10150 !      s13d=0.0d0
10151 #ifdef MOMENT
10152       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10153                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10154 #else
10155       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10156                     -0.5d0*ekont*(s2d+s12d)
10157 #endif
10158 ! Cartesian derivatives
10159       do iii=1,2
10160         do kkk=1,5
10161           do lll=1,3
10162 #ifdef MOMENT
10163             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10164             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10165             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10166 #endif
10167             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10168             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10169                 vtemp1d(1))
10170             s2d = scalar2(b1(1,itk),vtemp1d(1))
10171 #ifdef MOMENT
10172             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10173             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10174             s8d = -(atempd(1,1)+atempd(2,2))* &
10175                  scalar2(cc(1,1,itl),vtemp2(1))
10176 #endif
10177             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10178                  auxmatd(1,1))
10179             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10180             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10181 !      s1d=0.0d0
10182 !      s2d=0.0d0
10183 !      s8d=0.0d0
10184 !      s12d=0.0d0
10185 !      s13d=0.0d0
10186 #ifdef MOMENT
10187             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10188               - 0.5d0*(s1d+s2d)
10189 #else
10190             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10191               - 0.5d0*s2d
10192 #endif
10193 #ifdef MOMENT
10194             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10195               - 0.5d0*(s8d+s12d)
10196 #else
10197             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10198               - 0.5d0*s12d
10199 #endif
10200           enddo
10201         enddo
10202       enddo
10203 #ifdef MOMENT
10204       do kkk=1,5
10205         do lll=1,3
10206           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10207             achuj_tempd(1,1))
10208           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10209           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10210           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10211           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10212           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10213             vtemp4d(1))
10214           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10215           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10216           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10217         enddo
10218       enddo
10219 #endif
10220 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10221 !d     &  16*eel_turn6_num
10222 !d      goto 1112
10223       if (j.lt.nres-1) then
10224         j1=j+1
10225         j2=j-1
10226       else
10227         j1=j-1
10228         j2=j-2
10229       endif
10230       if (l.lt.nres-1) then
10231         l1=l+1
10232         l2=l-1
10233       else
10234         l1=l-1
10235         l2=l-2
10236       endif
10237       do ll=1,3
10238 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10239 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10240 !grad        ghalf=0.5d0*ggg1(ll)
10241 !d        ghalf=0.0d0
10242         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10243         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10244         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10245           +ekont*derx_turn(ll,2,1)
10246         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10247         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10248           +ekont*derx_turn(ll,4,1)
10249         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10250         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10251         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10252 !grad        ghalf=0.5d0*ggg2(ll)
10253 !d        ghalf=0.0d0
10254         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10255           +ekont*derx_turn(ll,2,2)
10256         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10257         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10258           +ekont*derx_turn(ll,4,2)
10259         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10260         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10261         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10262       enddo
10263 !d      goto 1112
10264 !grad      do m=i+1,j-1
10265 !grad        do ll=1,3
10266 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10267 !grad        enddo
10268 !grad      enddo
10269 !grad      do m=k+1,l-1
10270 !grad        do ll=1,3
10271 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10272 !grad        enddo
10273 !grad      enddo
10274 !grad1112  continue
10275 !grad      do m=i+2,j2
10276 !grad        do ll=1,3
10277 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10278 !grad        enddo
10279 !grad      enddo
10280 !grad      do m=k+2,l2
10281 !grad        do ll=1,3
10282 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10283 !grad        enddo
10284 !grad      enddo
10285 !d      do iii=1,nres-3
10286 !d        write (2,*) iii,g_corr6_loc(iii)
10287 !d      enddo
10288       eello_turn6=ekont*eel_turn6
10289 !d      write (2,*) 'ekont',ekont
10290 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10291       return
10292       end function eello_turn6
10293 !-----------------------------------------------------------------------------
10294       subroutine MATVEC2(A1,V1,V2)
10295 !DIR$ INLINEALWAYS MATVEC2
10296 #ifndef OSF
10297 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10298 #endif
10299 !      implicit real*8 (a-h,o-z)
10300 !      include 'DIMENSIONS'
10301       real(kind=8),dimension(2) :: V1,V2
10302       real(kind=8),dimension(2,2) :: A1
10303       real(kind=8) :: vaux1,vaux2
10304 !      DO 1 I=1,2
10305 !        VI=0.0
10306 !        DO 3 K=1,2
10307 !    3     VI=VI+A1(I,K)*V1(K)
10308 !        Vaux(I)=VI
10309 !    1 CONTINUE
10310
10311       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10312       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10313
10314       v2(1)=vaux1
10315       v2(2)=vaux2
10316       end subroutine MATVEC2
10317 !-----------------------------------------------------------------------------
10318       subroutine MATMAT2(A1,A2,A3)
10319 #ifndef OSF
10320 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10321 #endif
10322 !      implicit real*8 (a-h,o-z)
10323 !      include 'DIMENSIONS'
10324       real(kind=8),dimension(2,2) :: A1,A2,A3
10325       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10326 !      DIMENSION AI3(2,2)
10327 !        DO  J=1,2
10328 !          A3IJ=0.0
10329 !          DO K=1,2
10330 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10331 !          enddo
10332 !          A3(I,J)=A3IJ
10333 !       enddo
10334 !      enddo
10335
10336       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10337       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10338       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10339       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10340
10341       A3(1,1)=AI3_11
10342       A3(2,1)=AI3_21
10343       A3(1,2)=AI3_12
10344       A3(2,2)=AI3_22
10345       end subroutine MATMAT2
10346 !-----------------------------------------------------------------------------
10347       real(kind=8) function scalar2(u,v)
10348 !DIR$ INLINEALWAYS scalar2
10349       implicit none
10350       real(kind=8),dimension(2) :: u,v
10351       real(kind=8) :: sc
10352       integer :: i
10353       scalar2=u(1)*v(1)+u(2)*v(2)
10354       return
10355       end function scalar2
10356 !-----------------------------------------------------------------------------
10357       subroutine transpose2(a,at)
10358 !DIR$ INLINEALWAYS transpose2
10359 #ifndef OSF
10360 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10361 #endif
10362       implicit none
10363       real(kind=8),dimension(2,2) :: a,at
10364       at(1,1)=a(1,1)
10365       at(1,2)=a(2,1)
10366       at(2,1)=a(1,2)
10367       at(2,2)=a(2,2)
10368       return
10369       end subroutine transpose2
10370 !-----------------------------------------------------------------------------
10371       subroutine transpose(n,a,at)
10372       implicit none
10373       integer :: n,i,j
10374       real(kind=8),dimension(n,n) :: a,at
10375       do i=1,n
10376         do j=1,n
10377           at(j,i)=a(i,j)
10378         enddo
10379       enddo
10380       return
10381       end subroutine transpose
10382 !-----------------------------------------------------------------------------
10383       subroutine prodmat3(a1,a2,kk,transp,prod)
10384 !DIR$ INLINEALWAYS prodmat3
10385 #ifndef OSF
10386 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10387 #endif
10388       implicit none
10389       integer :: i,j
10390       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10391       logical :: transp
10392 !rc      double precision auxmat(2,2),prod_(2,2)
10393
10394       if (transp) then
10395 !rc        call transpose2(kk(1,1),auxmat(1,1))
10396 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10397 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10398
10399            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10400        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10401            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10402        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10403            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10404        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10405            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10406        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10407
10408       else
10409 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10410 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10411
10412            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10413         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10414            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10415         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10416            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10417         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10418            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10419         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10420
10421       endif
10422 !      call transpose2(a2(1,1),a2t(1,1))
10423
10424 !rc      print *,transp
10425 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10426 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10427
10428       return
10429       end subroutine prodmat3
10430 !-----------------------------------------------------------------------------
10431 ! energy_p_new_barrier.F
10432 !-----------------------------------------------------------------------------
10433       subroutine sum_gradient
10434 !      implicit real*8 (a-h,o-z)
10435       use io_base, only: pdbout
10436 !      include 'DIMENSIONS'
10437 #ifndef ISNAN
10438       external proc_proc
10439 #ifdef WINPGI
10440 !MS$ATTRIBUTES C ::  proc_proc
10441 #endif
10442 #endif
10443 #ifdef MPI
10444       include 'mpif.h'
10445 #endif
10446       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10447                    gloc_scbuf !(3,maxres)
10448
10449       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10450 !#endif
10451 !el local variables
10452       integer :: i,j,k,ierror,ierr
10453       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10454                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10455                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10456                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10457                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10458                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10459                    gsccorr_max,gsccorrx_max,time00
10460
10461 !      include 'COMMON.SETUP'
10462 !      include 'COMMON.IOUNITS'
10463 !      include 'COMMON.FFIELD'
10464 !      include 'COMMON.DERIV'
10465 !      include 'COMMON.INTERACT'
10466 !      include 'COMMON.SBRIDGE'
10467 !      include 'COMMON.CHAIN'
10468 !      include 'COMMON.VAR'
10469 !      include 'COMMON.CONTROL'
10470 !      include 'COMMON.TIME1'
10471 !      include 'COMMON.MAXGRAD'
10472 !      include 'COMMON.SCCOR'
10473 #ifdef TIMING
10474       time01=MPI_Wtime()
10475 #endif
10476 #ifdef DEBUG
10477       write (iout,*) "sum_gradient gvdwc, gvdwx"
10478       do i=1,nres
10479         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10480          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10481       enddo
10482       call flush(iout)
10483 #endif
10484 #ifdef MPI
10485         gradbufc=0.0d0
10486         gradbufx=0.0d0
10487         gradbufc_sum=0.0d0
10488         gloc_scbuf=0.0d0
10489         glocbuf=0.0d0
10490 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10491         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10492           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10493 #endif
10494 !
10495 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10496 !            in virtual-bond-vector coordinates
10497 !
10498 #ifdef DEBUG
10499 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10500 !      do i=1,nres-1
10501 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10502 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10503 !      enddo
10504 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10505 !      do i=1,nres-1
10506 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10507 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10508 !      enddo
10509       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10510       do i=1,nres
10511         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10512          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10513          (gvdwc_scpp(j,i),j=1,3)
10514       enddo
10515       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10516       do i=1,nres
10517         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10518          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10519          (gelc_loc_long(j,i),j=1,3)
10520       enddo
10521       call flush(iout)
10522 #endif
10523 #ifdef SPLITELE
10524       do i=0,nct
10525         do j=1,3
10526           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10527                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10528                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10529                       wel_loc*gel_loc_long(j,i)+ &
10530                       wcorr*gradcorr_long(j,i)+ &
10531                       wcorr5*gradcorr5_long(j,i)+ &
10532                       wcorr6*gradcorr6_long(j,i)+ &
10533                       wturn6*gcorr6_turn_long(j,i)+ &
10534                       wstrain*ghpbc(j,i) &
10535                      +wliptran*gliptranc(j,i) &
10536                      +gradafm(j,i) &
10537                      +welec*gshieldc(j,i) &
10538                      +wcorr*gshieldc_ec(j,i) &
10539                      +wturn3*gshieldc_t3(j,i)&
10540                      +wturn4*gshieldc_t4(j,i)&
10541                      +wel_loc*gshieldc_ll(j,i)&
10542                      +wtube*gg_tube(j,i) &
10543                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10544                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10545                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10546                      wcorr_nucl*gradcorr_nucl(j,i)&
10547                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10548                      wcatprot* gradpepcat(j,i)+ &
10549                      wcatcat*gradcatcat(j,i)+   &
10550                      wscbase*gvdwc_scbase(j,i)+ &
10551                      wpepbase*gvdwc_pepbase(j,i)+&
10552                      wscpho*gvdwc_scpho(j,i)+   &
10553                      wpeppho*gvdwc_peppho(j,i)
10554
10555
10556
10557
10558
10559         enddo
10560       enddo
10561 #else
10562       do i=0,nct
10563         do j=1,3
10564           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10565                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10566                       welec*gelc_long(j,i)+ &
10567                       wbond*gradb(j,i)+ &
10568                       wel_loc*gel_loc_long(j,i)+ &
10569                       wcorr*gradcorr_long(j,i)+ &
10570                       wcorr5*gradcorr5_long(j,i)+ &
10571                       wcorr6*gradcorr6_long(j,i)+ &
10572                       wturn6*gcorr6_turn_long(j,i)+ &
10573                       wstrain*ghpbc(j,i) &
10574                      +wliptran*gliptranc(j,i) &
10575                      +gradafm(j,i) &
10576                      +welec*gshieldc(j,i)&
10577                      +wcorr*gshieldc_ec(j,i) &
10578                      +wturn4*gshieldc_t4(j,i) &
10579                      +wel_loc*gshieldc_ll(j,i)&
10580                      +wtube*gg_tube(j,i) &
10581                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10582                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10583                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10584                      wcorr_nucl*gradcorr_nucl(j,i) &
10585                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10586                      wcatprot* gradpepcat(j,i)+ &
10587                      wcatcat*gradcatcat(j,i)+   &
10588                      wscbase*gvdwc_scbase(j,i)  &
10589                      wpepbase*gvdwc_pepbase(j,i)+&
10590                      wscpho*gvdwc_scpho(j,i)+&
10591                      wpeppho*gvdwc_peppho(j,i)
10592
10593
10594         enddo
10595       enddo
10596 #endif
10597 #ifdef MPI
10598       if (nfgtasks.gt.1) then
10599       time00=MPI_Wtime()
10600 #ifdef DEBUG
10601       write (iout,*) "gradbufc before allreduce"
10602       do i=1,nres
10603         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10604       enddo
10605       call flush(iout)
10606 #endif
10607       do i=0,nres
10608         do j=1,3
10609           gradbufc_sum(j,i)=gradbufc(j,i)
10610         enddo
10611       enddo
10612 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10613 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10614 !      time_reduce=time_reduce+MPI_Wtime()-time00
10615 #ifdef DEBUG
10616 !      write (iout,*) "gradbufc_sum after allreduce"
10617 !      do i=1,nres
10618 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10619 !      enddo
10620 !      call flush(iout)
10621 #endif
10622 #ifdef TIMING
10623 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10624 #endif
10625       do i=0,nres
10626         do k=1,3
10627           gradbufc(k,i)=0.0d0
10628         enddo
10629       enddo
10630 #ifdef DEBUG
10631       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10632       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10633                         " jgrad_end  ",jgrad_end(i),&
10634                         i=igrad_start,igrad_end)
10635 #endif
10636 !
10637 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10638 ! do not parallelize this part.
10639 !
10640 !      do i=igrad_start,igrad_end
10641 !        do j=jgrad_start(i),jgrad_end(i)
10642 !          do k=1,3
10643 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10644 !          enddo
10645 !        enddo
10646 !      enddo
10647       do j=1,3
10648         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10649       enddo
10650       do i=nres-2,-1,-1
10651         do j=1,3
10652           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10653         enddo
10654       enddo
10655 #ifdef DEBUG
10656       write (iout,*) "gradbufc after summing"
10657       do i=1,nres
10658         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10659       enddo
10660       call flush(iout)
10661 #endif
10662       else
10663 #endif
10664 !el#define DEBUG
10665 #ifdef DEBUG
10666       write (iout,*) "gradbufc"
10667       do i=1,nres
10668         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10669       enddo
10670       call flush(iout)
10671 #endif
10672 !el#undef DEBUG
10673       do i=-1,nres
10674         do j=1,3
10675           gradbufc_sum(j,i)=gradbufc(j,i)
10676           gradbufc(j,i)=0.0d0
10677         enddo
10678       enddo
10679       do j=1,3
10680         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10681       enddo
10682       do i=nres-2,-1,-1
10683         do j=1,3
10684           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10685         enddo
10686       enddo
10687 !      do i=nnt,nres-1
10688 !        do k=1,3
10689 !          gradbufc(k,i)=0.0d0
10690 !        enddo
10691 !        do j=i+1,nres
10692 !          do k=1,3
10693 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10694 !          enddo
10695 !        enddo
10696 !      enddo
10697 !el#define DEBUG
10698 #ifdef DEBUG
10699       write (iout,*) "gradbufc after summing"
10700       do i=1,nres
10701         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10702       enddo
10703       call flush(iout)
10704 #endif
10705 !el#undef DEBUG
10706 #ifdef MPI
10707       endif
10708 #endif
10709       do k=1,3
10710         gradbufc(k,nres)=0.0d0
10711       enddo
10712 !el----------------
10713 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10714 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10715 !el-----------------
10716       do i=-1,nct
10717         do j=1,3
10718 #ifdef SPLITELE
10719           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10720                       wel_loc*gel_loc(j,i)+ &
10721                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10722                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10723                       wel_loc*gel_loc_long(j,i)+ &
10724                       wcorr*gradcorr_long(j,i)+ &
10725                       wcorr5*gradcorr5_long(j,i)+ &
10726                       wcorr6*gradcorr6_long(j,i)+ &
10727                       wturn6*gcorr6_turn_long(j,i))+ &
10728                       wbond*gradb(j,i)+ &
10729                       wcorr*gradcorr(j,i)+ &
10730                       wturn3*gcorr3_turn(j,i)+ &
10731                       wturn4*gcorr4_turn(j,i)+ &
10732                       wcorr5*gradcorr5(j,i)+ &
10733                       wcorr6*gradcorr6(j,i)+ &
10734                       wturn6*gcorr6_turn(j,i)+ &
10735                       wsccor*gsccorc(j,i) &
10736                      +wscloc*gscloc(j,i)  &
10737                      +wliptran*gliptranc(j,i) &
10738                      +gradafm(j,i) &
10739                      +welec*gshieldc(j,i) &
10740                      +welec*gshieldc_loc(j,i) &
10741                      +wcorr*gshieldc_ec(j,i) &
10742                      +wcorr*gshieldc_loc_ec(j,i) &
10743                      +wturn3*gshieldc_t3(j,i) &
10744                      +wturn3*gshieldc_loc_t3(j,i) &
10745                      +wturn4*gshieldc_t4(j,i) &
10746                      +wturn4*gshieldc_loc_t4(j,i) &
10747                      +wel_loc*gshieldc_ll(j,i) &
10748                      +wel_loc*gshieldc_loc_ll(j,i) &
10749                      +wtube*gg_tube(j,i) &
10750                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10751                      +wvdwpsb*gvdwpsb1(j,i))&
10752                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10753
10754 !                 if ((i.le.2).and.(i.ge.1))
10755 !                       print *,gradc(j,i,icg),&
10756 !                      gradbufc(j,i),welec*gelc(j,i), &
10757 !                      wel_loc*gel_loc(j,i), &
10758 !                      wscp*gvdwc_scpp(j,i), &
10759 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10760 !                      wel_loc*gel_loc_long(j,i), &
10761 !                      wcorr*gradcorr_long(j,i), &
10762 !                      wcorr5*gradcorr5_long(j,i), &
10763 !                      wcorr6*gradcorr6_long(j,i), &
10764 !                      wturn6*gcorr6_turn_long(j,i), &
10765 !                      wbond*gradb(j,i), &
10766 !                      wcorr*gradcorr(j,i), &
10767 !                      wturn3*gcorr3_turn(j,i), &
10768 !                      wturn4*gcorr4_turn(j,i), &
10769 !                      wcorr5*gradcorr5(j,i), &
10770 !                      wcorr6*gradcorr6(j,i), &
10771 !                      wturn6*gcorr6_turn(j,i), &
10772 !                      wsccor*gsccorc(j,i) &
10773 !                     ,wscloc*gscloc(j,i)  &
10774 !                     ,wliptran*gliptranc(j,i) &
10775 !                    ,gradafm(j,i) &
10776 !                     ,welec*gshieldc(j,i) &
10777 !                     ,welec*gshieldc_loc(j,i) &
10778 !                     ,wcorr*gshieldc_ec(j,i) &
10779 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10780 !                     ,wturn3*gshieldc_t3(j,i) &
10781 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10782 !                     ,wturn4*gshieldc_t4(j,i) &
10783 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10784 !                     ,wel_loc*gshieldc_ll(j,i) &
10785 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10786 !                     ,wtube*gg_tube(j,i) &
10787 !                     ,wbond_nucl*gradb_nucl(j,i) &
10788 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10789 !                     wvdwpsb*gvdwpsb1(j,i)&
10790 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10791 !
10792
10793 #else
10794           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10795                       wel_loc*gel_loc(j,i)+ &
10796                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10797                       welec*gelc_long(j,i)+ &
10798                       wel_loc*gel_loc_long(j,i)+ &
10799 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10800                       wcorr5*gradcorr5_long(j,i)+ &
10801                       wcorr6*gradcorr6_long(j,i)+ &
10802                       wturn6*gcorr6_turn_long(j,i))+ &
10803                       wbond*gradb(j,i)+ &
10804                       wcorr*gradcorr(j,i)+ &
10805                       wturn3*gcorr3_turn(j,i)+ &
10806                       wturn4*gcorr4_turn(j,i)+ &
10807                       wcorr5*gradcorr5(j,i)+ &
10808                       wcorr6*gradcorr6(j,i)+ &
10809                       wturn6*gcorr6_turn(j,i)+ &
10810                       wsccor*gsccorc(j,i) &
10811                      +wscloc*gscloc(j,i) &
10812                      +gradafm(j,i) &
10813                      +wliptran*gliptranc(j,i) &
10814                      +welec*gshieldc(j,i) &
10815                      +welec*gshieldc_loc(j,) &
10816                      +wcorr*gshieldc_ec(j,i) &
10817                      +wcorr*gshieldc_loc_ec(j,i) &
10818                      +wturn3*gshieldc_t3(j,i) &
10819                      +wturn3*gshieldc_loc_t3(j,i) &
10820                      +wturn4*gshieldc_t4(j,i) &
10821                      +wturn4*gshieldc_loc_t4(j,i) &
10822                      +wel_loc*gshieldc_ll(j,i) &
10823                      +wel_loc*gshieldc_loc_ll(j,i) &
10824                      +wtube*gg_tube(j,i) &
10825                      +wbond_nucl*gradb_nucl(j,i) &
10826                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10827                      +wvdwpsb*gvdwpsb1(j,i))&
10828                      +wsbloc*gsbloc(j,i)
10829
10830
10831
10832
10833 #endif
10834           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10835                         wbond*gradbx(j,i)+ &
10836                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10837                         wsccor*gsccorx(j,i) &
10838                        +wscloc*gsclocx(j,i) &
10839                        +wliptran*gliptranx(j,i) &
10840                        +welec*gshieldx(j,i)     &
10841                        +wcorr*gshieldx_ec(j,i)  &
10842                        +wturn3*gshieldx_t3(j,i) &
10843                        +wturn4*gshieldx_t4(j,i) &
10844                        +wel_loc*gshieldx_ll(j,i)&
10845                        +wtube*gg_tube_sc(j,i)   &
10846                        +wbond_nucl*gradbx_nucl(j,i) &
10847                        +wvdwsb*gvdwsbx(j,i) &
10848                        +welsb*gelsbx(j,i) &
10849                        +wcorr_nucl*gradxorr_nucl(j,i)&
10850                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10851                        +wsbloc*gsblocx(j,i) &
10852                        +wcatprot* gradpepcatx(j,i)&
10853                        +wscbase*gvdwx_scbase(j,i) &
10854                        +wpepbase*gvdwx_pepbase(j,i)&
10855                        +wscpho*gvdwx_scpho(j,i)
10856 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
10857
10858         enddo
10859       enddo
10860 #ifdef DEBUG
10861       write (iout,*) "gloc before adding corr"
10862       do i=1,4*nres
10863         write (iout,*) i,gloc(i,icg)
10864       enddo
10865 #endif
10866       do i=1,nres-3
10867         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10868          +wcorr5*g_corr5_loc(i) &
10869          +wcorr6*g_corr6_loc(i) &
10870          +wturn4*gel_loc_turn4(i) &
10871          +wturn3*gel_loc_turn3(i) &
10872          +wturn6*gel_loc_turn6(i) &
10873          +wel_loc*gel_loc_loc(i)
10874       enddo
10875 #ifdef DEBUG
10876       write (iout,*) "gloc after adding corr"
10877       do i=1,4*nres
10878         write (iout,*) i,gloc(i,icg)
10879       enddo
10880 #endif
10881 #ifdef MPI
10882       if (nfgtasks.gt.1) then
10883         do j=1,3
10884           do i=0,nres
10885             gradbufc(j,i)=gradc(j,i,icg)
10886             gradbufx(j,i)=gradx(j,i,icg)
10887           enddo
10888         enddo
10889         do i=1,4*nres
10890           glocbuf(i)=gloc(i,icg)
10891         enddo
10892 !#define DEBUG
10893 #ifdef DEBUG
10894       write (iout,*) "gloc_sc before reduce"
10895       do i=1,nres
10896        do j=1,1
10897         write (iout,*) i,j,gloc_sc(j,i,icg)
10898        enddo
10899       enddo
10900 #endif
10901 !#undef DEBUG
10902         do i=1,nres
10903          do j=1,3
10904           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10905          enddo
10906         enddo
10907         time00=MPI_Wtime()
10908         call MPI_Barrier(FG_COMM,IERR)
10909         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10910         time00=MPI_Wtime()
10911         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10912           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10913         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10914           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10915         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10916           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10917         time_reduce=time_reduce+MPI_Wtime()-time00
10918         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10919           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10920         time_reduce=time_reduce+MPI_Wtime()-time00
10921 !#define DEBUG
10922 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10923 #ifdef DEBUG
10924       write (iout,*) "gloc_sc after reduce"
10925       do i=1,nres
10926        do j=1,1
10927         write (iout,*) i,j,gloc_sc(j,i,icg)
10928        enddo
10929       enddo
10930 #endif
10931 !#undef DEBUG
10932 #ifdef DEBUG
10933       write (iout,*) "gloc after reduce"
10934       do i=1,4*nres
10935         write (iout,*) i,gloc(i,icg)
10936       enddo
10937 #endif
10938       endif
10939 #endif
10940       if (gnorm_check) then
10941 !
10942 ! Compute the maximum elements of the gradient
10943 !
10944       gvdwc_max=0.0d0
10945       gvdwc_scp_max=0.0d0
10946       gelc_max=0.0d0
10947       gvdwpp_max=0.0d0
10948       gradb_max=0.0d0
10949       ghpbc_max=0.0d0
10950       gradcorr_max=0.0d0
10951       gel_loc_max=0.0d0
10952       gcorr3_turn_max=0.0d0
10953       gcorr4_turn_max=0.0d0
10954       gradcorr5_max=0.0d0
10955       gradcorr6_max=0.0d0
10956       gcorr6_turn_max=0.0d0
10957       gsccorc_max=0.0d0
10958       gscloc_max=0.0d0
10959       gvdwx_max=0.0d0
10960       gradx_scp_max=0.0d0
10961       ghpbx_max=0.0d0
10962       gradxorr_max=0.0d0
10963       gsccorx_max=0.0d0
10964       gsclocx_max=0.0d0
10965       do i=1,nct
10966         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10967         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10968         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10969         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10970          gvdwc_scp_max=gvdwc_scp_norm
10971         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10972         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10973         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10974         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10975         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10976         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10977         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10978         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10979         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10980         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10981         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10982         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10983         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10984           gcorr3_turn(1,i)))
10985         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10986           gcorr3_turn_max=gcorr3_turn_norm
10987         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10988           gcorr4_turn(1,i)))
10989         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10990           gcorr4_turn_max=gcorr4_turn_norm
10991         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10992         if (gradcorr5_norm.gt.gradcorr5_max) &
10993           gradcorr5_max=gradcorr5_norm
10994         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10995         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10996         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10997           gcorr6_turn(1,i)))
10998         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10999           gcorr6_turn_max=gcorr6_turn_norm
11000         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11001         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11002         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11003         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11004         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11005         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11006         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11007         if (gradx_scp_norm.gt.gradx_scp_max) &
11008           gradx_scp_max=gradx_scp_norm
11009         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11010         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11011         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11012         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11013         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11014         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11015         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11016         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11017       enddo
11018       if (gradout) then
11019 #ifdef AIX
11020         open(istat,file=statname,position="append")
11021 #else
11022         open(istat,file=statname,access="append")
11023 #endif
11024         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11025            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11026            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11027            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11028            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11029            gsccorx_max,gsclocx_max
11030         close(istat)
11031         if (gvdwc_max.gt.1.0d4) then
11032           write (iout,*) "gvdwc gvdwx gradb gradbx"
11033           do i=nnt,nct
11034             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11035               gradb(j,i),gradbx(j,i),j=1,3)
11036           enddo
11037           call pdbout(0.0d0,'cipiszcze',iout)
11038           call flush(iout)
11039         endif
11040       endif
11041       endif
11042 !el#define DEBUG
11043 #ifdef DEBUG
11044       write (iout,*) "gradc gradx gloc"
11045       do i=1,nres
11046         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11047          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11048       enddo
11049 #endif
11050 !el#undef DEBUG
11051 #ifdef TIMING
11052       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11053 #endif
11054       return
11055       end subroutine sum_gradient
11056 !-----------------------------------------------------------------------------
11057       subroutine sc_grad
11058 !      implicit real*8 (a-h,o-z)
11059       use calc_data
11060 !      include 'DIMENSIONS'
11061 !      include 'COMMON.CHAIN'
11062 !      include 'COMMON.DERIV'
11063 !      include 'COMMON.CALC'
11064 !      include 'COMMON.IOUNITS'
11065       real(kind=8), dimension(3) :: dcosom1,dcosom2
11066 !      print *,"wchodze"
11067       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
11068       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
11069       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11070            -2.0D0*alf12*eps3der+sigder*sigsq_om12
11071 ! diagnostics only
11072 !      eom1=0.0d0
11073 !      eom2=0.0d0
11074 !      eom12=evdwij*eps1_om12
11075 ! end diagnostics
11076 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11077 !       " sigder",sigder
11078 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11079 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11080 !C      print *,sss_ele_cut,'in sc_grad'
11081       do k=1,3
11082         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11083         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11084       enddo
11085       do k=1,3
11086         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11087 !C      print *,'gg',k,gg(k)
11088        enddo
11089 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11090 !      write (iout,*) "gg",(gg(k),k=1,3)
11091       do k=1,3
11092         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11093                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11094                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11095                   *sss_ele_cut
11096
11097         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11098                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11099                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11100                   *sss_ele_cut
11101
11102 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11103 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11104 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11105 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11106       enddo
11107 !
11108 ! Calculate the components of the gradient in DC and X
11109 !
11110 !grad      do k=i,j-1
11111 !grad        do l=1,3
11112 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11113 !grad        enddo
11114 !grad      enddo
11115       do l=1,3
11116         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11117         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11118       enddo
11119       return
11120       end subroutine sc_grad
11121 #ifdef CRYST_THETA
11122 !-----------------------------------------------------------------------------
11123       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11124
11125       use comm_calcthet
11126 !      implicit real*8 (a-h,o-z)
11127 !      include 'DIMENSIONS'
11128 !      include 'COMMON.LOCAL'
11129 !      include 'COMMON.IOUNITS'
11130 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11131 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11132 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11133       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11134       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11135 !el      integer :: it
11136 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11137 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11138 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11139 !el local variables
11140
11141       delthec=thetai-thet_pred_mean
11142       delthe0=thetai-theta0i
11143 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11144       t3 = thetai-thet_pred_mean
11145       t6 = t3**2
11146       t9 = term1
11147       t12 = t3*sigcsq
11148       t14 = t12+t6*sigsqtc
11149       t16 = 1.0d0
11150       t21 = thetai-theta0i
11151       t23 = t21**2
11152       t26 = term2
11153       t27 = t21*t26
11154       t32 = termexp
11155       t40 = t32**2
11156       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11157        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11158        *(-t12*t9-ak*sig0inv*t27)
11159       return
11160       end subroutine mixder
11161 #endif
11162 !-----------------------------------------------------------------------------
11163 ! cartder.F
11164 !-----------------------------------------------------------------------------
11165       subroutine cartder
11166 !-----------------------------------------------------------------------------
11167 ! This subroutine calculates the derivatives of the consecutive virtual
11168 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11169 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11170 ! in the angles alpha and omega, describing the location of a side chain
11171 ! in its local coordinate system.
11172 !
11173 ! The derivatives are stored in the following arrays:
11174 !
11175 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11176 ! The structure is as follows:
11177 !
11178 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11179 ! 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)
11180 !         . . . . . . . . . . . .  . . . . . .
11181 ! 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)
11182 !                          .
11183 !                          .
11184 !                          .
11185 ! 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)
11186 !
11187 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11188 ! The structure is same as above.
11189 !
11190 ! DCDS - the derivatives of the side chain vectors in the local spherical
11191 ! andgles alph and omega:
11192 !
11193 ! 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)
11194 ! 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)
11195 !                          .
11196 !                          .
11197 !                          .
11198 ! 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)
11199 !
11200 ! Version of March '95, based on an early version of November '91.
11201 !
11202 !**********************************************************************
11203 !      implicit real*8 (a-h,o-z)
11204 !      include 'DIMENSIONS'
11205 !      include 'COMMON.VAR'
11206 !      include 'COMMON.CHAIN'
11207 !      include 'COMMON.DERIV'
11208 !      include 'COMMON.GEO'
11209 !      include 'COMMON.LOCAL'
11210 !      include 'COMMON.INTERACT'
11211       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11212       real(kind=8),dimension(3,3) :: dp,temp
11213 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11214       real(kind=8),dimension(3) :: xx,xx1
11215 !el local variables
11216       integer :: i,k,l,j,m,ind,ind1,jjj
11217       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11218                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11219                  sint2,xp,yp,xxp,yyp,zzp,dj
11220
11221 !      common /przechowalnia/ fromto
11222       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11223 ! get the position of the jth ijth fragment of the chain coordinate system
11224 ! in the fromto array.
11225 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11226 !
11227 !      maxdim=(nres-1)*(nres-2)/2
11228 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11229 ! calculate the derivatives of transformation matrix elements in theta
11230 !
11231
11232 !el      call flush(iout) !el
11233       do i=1,nres-2
11234         rdt(1,1,i)=-rt(1,2,i)
11235         rdt(1,2,i)= rt(1,1,i)
11236         rdt(1,3,i)= 0.0d0
11237         rdt(2,1,i)=-rt(2,2,i)
11238         rdt(2,2,i)= rt(2,1,i)
11239         rdt(2,3,i)= 0.0d0
11240         rdt(3,1,i)=-rt(3,2,i)
11241         rdt(3,2,i)= rt(3,1,i)
11242         rdt(3,3,i)= 0.0d0
11243       enddo
11244 !
11245 ! derivatives in phi
11246 !
11247       do i=2,nres-2
11248         drt(1,1,i)= 0.0d0
11249         drt(1,2,i)= 0.0d0
11250         drt(1,3,i)= 0.0d0
11251         drt(2,1,i)= rt(3,1,i)
11252         drt(2,2,i)= rt(3,2,i)
11253         drt(2,3,i)= rt(3,3,i)
11254         drt(3,1,i)=-rt(2,1,i)
11255         drt(3,2,i)=-rt(2,2,i)
11256         drt(3,3,i)=-rt(2,3,i)
11257       enddo
11258 !
11259 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11260 !
11261       do i=2,nres-2
11262         ind=indmat(i,i+1)
11263         do k=1,3
11264           do l=1,3
11265             temp(k,l)=rt(k,l,i)
11266           enddo
11267         enddo
11268         do k=1,3
11269           do l=1,3
11270             fromto(k,l,ind)=temp(k,l)
11271           enddo
11272         enddo
11273         do j=i+1,nres-2
11274           ind=indmat(i,j+1)
11275           do k=1,3
11276             do l=1,3
11277               dpkl=0.0d0
11278               do m=1,3
11279                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11280               enddo
11281               dp(k,l)=dpkl
11282               fromto(k,l,ind)=dpkl
11283             enddo
11284           enddo
11285           do k=1,3
11286             do l=1,3
11287               temp(k,l)=dp(k,l)
11288             enddo
11289           enddo
11290         enddo
11291       enddo
11292 !
11293 ! Calculate derivatives.
11294 !
11295       ind1=0
11296       do i=1,nres-2
11297       ind1=ind1+1
11298 !
11299 ! Derivatives of DC(i+1) in theta(i+2)
11300 !
11301         do j=1,3
11302           do k=1,2
11303             dpjk=0.0D0
11304             do l=1,3
11305               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11306             enddo
11307             dp(j,k)=dpjk
11308             prordt(j,k,i)=dp(j,k)
11309           enddo
11310           dp(j,3)=0.0D0
11311           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11312         enddo
11313 !
11314 ! Derivatives of SC(i+1) in theta(i+2)
11315 !
11316         xx1(1)=-0.5D0*xloc(2,i+1)
11317         xx1(2)= 0.5D0*xloc(1,i+1)
11318         do j=1,3
11319           xj=0.0D0
11320           do k=1,2
11321             xj=xj+r(j,k,i)*xx1(k)
11322           enddo
11323           xx(j)=xj
11324         enddo
11325         do j=1,3
11326           rj=0.0D0
11327           do k=1,3
11328             rj=rj+prod(j,k,i)*xx(k)
11329           enddo
11330           dxdv(j,ind1)=rj
11331         enddo
11332 !
11333 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11334 ! than the other off-diagonal derivatives.
11335 !
11336         do j=1,3
11337           dxoiij=0.0D0
11338           do k=1,3
11339             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11340           enddo
11341           dxdv(j,ind1+1)=dxoiij
11342         enddo
11343 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11344 !
11345 ! Derivatives of DC(i+1) in phi(i+2)
11346 !
11347         do j=1,3
11348           do k=1,3
11349             dpjk=0.0
11350             do l=2,3
11351               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11352             enddo
11353             dp(j,k)=dpjk
11354             prodrt(j,k,i)=dp(j,k)
11355           enddo
11356           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11357         enddo
11358 !
11359 ! Derivatives of SC(i+1) in phi(i+2)
11360 !
11361         xx(1)= 0.0D0
11362         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11363         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11364         do j=1,3
11365           rj=0.0D0
11366           do k=2,3
11367             rj=rj+prod(j,k,i)*xx(k)
11368           enddo
11369           dxdv(j+3,ind1)=-rj
11370         enddo
11371 !
11372 ! Derivatives of SC(i+1) in phi(i+3).
11373 !
11374         do j=1,3
11375           dxoiij=0.0D0
11376           do k=1,3
11377             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11378           enddo
11379           dxdv(j+3,ind1+1)=dxoiij
11380         enddo
11381 !
11382 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11383 ! theta(nres) and phi(i+3) thru phi(nres).
11384 !
11385         do j=i+1,nres-2
11386         ind1=ind1+1
11387         ind=indmat(i+1,j+1)
11388 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11389           do k=1,3
11390             do l=1,3
11391               tempkl=0.0D0
11392               do m=1,2
11393                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11394               enddo
11395               temp(k,l)=tempkl
11396             enddo
11397           enddo
11398 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11399 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11400 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11401 ! Derivatives of virtual-bond vectors in theta
11402           do k=1,3
11403             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11404           enddo
11405 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11406 ! Derivatives of SC vectors in theta
11407           do k=1,3
11408             dxoijk=0.0D0
11409             do l=1,3
11410               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11411             enddo
11412             dxdv(k,ind1+1)=dxoijk
11413           enddo
11414 !
11415 !--- Calculate the derivatives in phi
11416 !
11417           do k=1,3
11418             do l=1,3
11419               tempkl=0.0D0
11420               do m=1,3
11421                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11422               enddo
11423               temp(k,l)=tempkl
11424             enddo
11425           enddo
11426           do k=1,3
11427             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11428         enddo
11429           do k=1,3
11430             dxoijk=0.0D0
11431             do l=1,3
11432               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11433             enddo
11434             dxdv(k+3,ind1+1)=dxoijk
11435           enddo
11436         enddo
11437       enddo
11438 !
11439 ! Derivatives in alpha and omega:
11440 !
11441       do i=2,nres-1
11442 !       dsci=dsc(itype(i,1))
11443         dsci=vbld(i+nres)
11444 #ifdef OSF
11445         alphi=alph(i)
11446         omegi=omeg(i)
11447         if(alphi.ne.alphi) alphi=100.0
11448         if(omegi.ne.omegi) omegi=-100.0
11449 #else
11450       alphi=alph(i)
11451       omegi=omeg(i)
11452 #endif
11453 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11454       cosalphi=dcos(alphi)
11455       sinalphi=dsin(alphi)
11456       cosomegi=dcos(omegi)
11457       sinomegi=dsin(omegi)
11458       temp(1,1)=-dsci*sinalphi
11459       temp(2,1)= dsci*cosalphi*cosomegi
11460       temp(3,1)=-dsci*cosalphi*sinomegi
11461       temp(1,2)=0.0D0
11462       temp(2,2)=-dsci*sinalphi*sinomegi
11463       temp(3,2)=-dsci*sinalphi*cosomegi
11464       theta2=pi-0.5D0*theta(i+1)
11465       cost2=dcos(theta2)
11466       sint2=dsin(theta2)
11467       jjj=0
11468 !d      print *,((temp(l,k),l=1,3),k=1,2)
11469         do j=1,2
11470         xp=temp(1,j)
11471         yp=temp(2,j)
11472         xxp= xp*cost2+yp*sint2
11473         yyp=-xp*sint2+yp*cost2
11474         zzp=temp(3,j)
11475         xx(1)=xxp
11476         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11477         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11478         do k=1,3
11479           dj=0.0D0
11480           do l=1,3
11481             dj=dj+prod(k,l,i-1)*xx(l)
11482             enddo
11483           dxds(jjj+k,i)=dj
11484           enddo
11485         jjj=jjj+3
11486       enddo
11487       enddo
11488       return
11489       end subroutine cartder
11490 !-----------------------------------------------------------------------------
11491 ! checkder_p.F
11492 !-----------------------------------------------------------------------------
11493       subroutine check_cartgrad
11494 ! Check the gradient of Cartesian coordinates in internal coordinates.
11495 !      implicit real*8 (a-h,o-z)
11496 !      include 'DIMENSIONS'
11497 !      include 'COMMON.IOUNITS'
11498 !      include 'COMMON.VAR'
11499 !      include 'COMMON.CHAIN'
11500 !      include 'COMMON.GEO'
11501 !      include 'COMMON.LOCAL'
11502 !      include 'COMMON.DERIV'
11503       real(kind=8),dimension(6,nres) :: temp
11504       real(kind=8),dimension(3) :: xx,gg
11505       integer :: i,k,j,ii
11506       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11507 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11508 !
11509 ! Check the gradient of the virtual-bond and SC vectors in the internal
11510 ! coordinates.
11511 !
11512       aincr=1.0d-6
11513       aincr2=5.0d-7
11514       call cartder
11515       write (iout,'(a)') '**************** dx/dalpha'
11516       write (iout,'(a)')
11517       do i=2,nres-1
11518       alphi=alph(i)
11519       alph(i)=alph(i)+aincr
11520       do k=1,3
11521         temp(k,i)=dc(k,nres+i)
11522         enddo
11523       call chainbuild
11524       do k=1,3
11525         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11526         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11527         enddo
11528         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11529         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11530         write (iout,'(a)')
11531       alph(i)=alphi
11532       call chainbuild
11533       enddo
11534       write (iout,'(a)')
11535       write (iout,'(a)') '**************** dx/domega'
11536       write (iout,'(a)')
11537       do i=2,nres-1
11538       omegi=omeg(i)
11539       omeg(i)=omeg(i)+aincr
11540       do k=1,3
11541         temp(k,i)=dc(k,nres+i)
11542         enddo
11543       call chainbuild
11544       do k=1,3
11545           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11546           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11547                 (aincr*dabs(dxds(k+3,i))+aincr))
11548         enddo
11549         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11550             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11551         write (iout,'(a)')
11552       omeg(i)=omegi
11553       call chainbuild
11554       enddo
11555       write (iout,'(a)')
11556       write (iout,'(a)') '**************** dx/dtheta'
11557       write (iout,'(a)')
11558       do i=3,nres
11559       theti=theta(i)
11560         theta(i)=theta(i)+aincr
11561         do j=i-1,nres-1
11562           do k=1,3
11563             temp(k,j)=dc(k,nres+j)
11564           enddo
11565         enddo
11566         call chainbuild
11567         do j=i-1,nres-1
11568         ii = indmat(i-2,j)
11569 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11570         do k=1,3
11571           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11572           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11573                   (aincr*dabs(dxdv(k,ii))+aincr))
11574           enddo
11575           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11576               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11577           write(iout,'(a)')
11578         enddo
11579         write (iout,'(a)')
11580         theta(i)=theti
11581         call chainbuild
11582       enddo
11583       write (iout,'(a)') '***************** dx/dphi'
11584       write (iout,'(a)')
11585       do i=4,nres
11586         phi(i)=phi(i)+aincr
11587         do j=i-1,nres-1
11588           do k=1,3
11589             temp(k,j)=dc(k,nres+j)
11590           enddo
11591         enddo
11592         call chainbuild
11593         do j=i-1,nres-1
11594         ii = indmat(i-2,j)
11595 !         print *,'ii=',ii
11596         do k=1,3
11597           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11598             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11599                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11600           enddo
11601           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11602               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11603           write(iout,'(a)')
11604         enddo
11605         phi(i)=phi(i)-aincr
11606         call chainbuild
11607       enddo
11608       write (iout,'(a)') '****************** ddc/dtheta'
11609       do i=1,nres-2
11610         thet=theta(i+2)
11611         theta(i+2)=thet+aincr
11612         do j=i,nres
11613           do k=1,3
11614             temp(k,j)=dc(k,j)
11615           enddo
11616         enddo
11617         call chainbuild
11618         do j=i+1,nres-1
11619         ii = indmat(i,j)
11620 !         print *,'ii=',ii
11621         do k=1,3
11622           gg(k)=(dc(k,j)-temp(k,j))/aincr
11623           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11624                  (aincr*dabs(dcdv(k,ii))+aincr))
11625           enddo
11626           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11627                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11628         write (iout,'(a)')
11629         enddo
11630         do j=1,nres
11631           do k=1,3
11632             dc(k,j)=temp(k,j)
11633           enddo
11634         enddo
11635         theta(i+2)=thet
11636       enddo
11637       write (iout,'(a)') '******************* ddc/dphi'
11638       do i=1,nres-3
11639         phii=phi(i+3)
11640         phi(i+3)=phii+aincr
11641         do j=1,nres
11642           do k=1,3
11643             temp(k,j)=dc(k,j)
11644           enddo
11645         enddo
11646         call chainbuild
11647         do j=i+2,nres-1
11648         ii = indmat(i+1,j)
11649 !         print *,'ii=',ii
11650         do k=1,3
11651           gg(k)=(dc(k,j)-temp(k,j))/aincr
11652             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11653                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11654           enddo
11655           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11656                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11657         write (iout,'(a)')
11658         enddo
11659         do j=1,nres
11660           do k=1,3
11661             dc(k,j)=temp(k,j)
11662           enddo
11663         enddo
11664         phi(i+3)=phii
11665       enddo
11666       return
11667       end subroutine check_cartgrad
11668 !-----------------------------------------------------------------------------
11669       subroutine check_ecart
11670 ! Check the gradient of the energy in Cartesian coordinates.
11671 !     implicit real*8 (a-h,o-z)
11672 !     include 'DIMENSIONS'
11673 !     include 'COMMON.CHAIN'
11674 !     include 'COMMON.DERIV'
11675 !     include 'COMMON.IOUNITS'
11676 !     include 'COMMON.VAR'
11677 !     include 'COMMON.CONTACTS'
11678       use comm_srutu
11679 !el      integer :: icall
11680 !el      common /srutu/ icall
11681       real(kind=8),dimension(6) :: ggg
11682       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11683       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11684       real(kind=8),dimension(6,nres) :: grad_s
11685       real(kind=8),dimension(0:n_ene) :: energia,energia1
11686       integer :: uiparm(1)
11687       real(kind=8) :: urparm(1)
11688 !EL      external fdum
11689       integer :: nf,i,j,k
11690       real(kind=8) :: aincr,etot,etot1
11691       icg=1
11692       nf=0
11693       nfl=0
11694       call zerograd
11695       aincr=1.0D-5
11696       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11697       nf=0
11698       icall=0
11699       call geom_to_var(nvar,x)
11700       call etotal(energia)
11701       etot=energia(0)
11702 !el      call enerprint(energia)
11703       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11704       icall =1
11705       do i=1,nres
11706         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11707       enddo
11708       do i=1,nres
11709       do j=1,3
11710         grad_s(j,i)=gradc(j,i,icg)
11711         grad_s(j+3,i)=gradx(j,i,icg)
11712         enddo
11713       enddo
11714       call flush(iout)
11715       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11716       do i=1,nres
11717         do j=1,3
11718         xx(j)=c(j,i+nres)
11719         ddc(j)=dc(j,i)
11720         ddx(j)=dc(j,i+nres)
11721         enddo
11722       do j=1,3
11723         dc(j,i)=dc(j,i)+aincr
11724         do k=i+1,nres
11725           c(j,k)=c(j,k)+aincr
11726           c(j,k+nres)=c(j,k+nres)+aincr
11727           enddo
11728           call etotal(energia1)
11729           etot1=energia1(0)
11730         ggg(j)=(etot1-etot)/aincr
11731         dc(j,i)=ddc(j)
11732         do k=i+1,nres
11733           c(j,k)=c(j,k)-aincr
11734           c(j,k+nres)=c(j,k+nres)-aincr
11735           enddo
11736         enddo
11737       do j=1,3
11738         c(j,i+nres)=c(j,i+nres)+aincr
11739         dc(j,i+nres)=dc(j,i+nres)+aincr
11740           call etotal(energia1)
11741           etot1=energia1(0)
11742         ggg(j+3)=(etot1-etot)/aincr
11743         c(j,i+nres)=xx(j)
11744         dc(j,i+nres)=ddx(j)
11745         enddo
11746       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11747          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11748       enddo
11749       return
11750       end subroutine check_ecart
11751 #ifdef CARGRAD
11752 !-----------------------------------------------------------------------------
11753       subroutine check_ecartint
11754 ! Check the gradient of the energy in Cartesian coordinates.
11755       use io_base, only: intout
11756 !      implicit real*8 (a-h,o-z)
11757 !      include 'DIMENSIONS'
11758 !      include 'COMMON.CONTROL'
11759 !      include 'COMMON.CHAIN'
11760 !      include 'COMMON.DERIV'
11761 !      include 'COMMON.IOUNITS'
11762 !      include 'COMMON.VAR'
11763 !      include 'COMMON.CONTACTS'
11764 !      include 'COMMON.MD'
11765 !      include 'COMMON.LOCAL'
11766 !      include 'COMMON.SPLITELE'
11767       use comm_srutu
11768 !el      integer :: icall
11769 !el      common /srutu/ icall
11770       real(kind=8),dimension(6) :: ggg,ggg1
11771       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11772       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11773       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11774       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11775       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11776       real(kind=8),dimension(0:n_ene) :: energia,energia1
11777       integer :: uiparm(1)
11778       real(kind=8) :: urparm(1)
11779 !EL      external fdum
11780       integer :: i,j,k,nf
11781       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11782                    etot21,etot22
11783       r_cut=2.0d0
11784       rlambd=0.3d0
11785       icg=1
11786       nf=0
11787       nfl=0
11788       call intout
11789 !      call intcartderiv
11790 !      call checkintcartgrad
11791       call zerograd
11792       aincr=1.0D-5
11793       write(iout,*) 'Calling CHECK_ECARTINT.'
11794       nf=0
11795       icall=0
11796       write (iout,*) "Before geom_to_var"
11797       call geom_to_var(nvar,x)
11798       write (iout,*) "after geom_to_var"
11799       write (iout,*) "split_ene ",split_ene
11800       call flush(iout)
11801       if (.not.split_ene) then
11802         write(iout,*) 'Calling CHECK_ECARTINT if'
11803         call etotal(energia)
11804 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11805         etot=energia(0)
11806         write (iout,*) "etot",etot
11807         call flush(iout)
11808 !el        call enerprint(energia)
11809 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11810         call flush(iout)
11811         write (iout,*) "enter cartgrad"
11812         call flush(iout)
11813         call cartgrad
11814 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11815         write (iout,*) "exit cartgrad"
11816         call flush(iout)
11817         icall =1
11818         do i=1,nres
11819           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11820         enddo
11821         do j=1,3
11822           grad_s(j,0)=gcart(j,0)
11823         enddo
11824 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11825         do i=1,nres
11826           do j=1,3
11827             grad_s(j,i)=gcart(j,i)
11828             grad_s(j+3,i)=gxcart(j,i)
11829           enddo
11830         enddo
11831       else
11832 write(iout,*) 'Calling CHECK_ECARTIN else.'
11833 !- split gradient check
11834         call zerograd
11835         call etotal_long(energia)
11836 !el        call enerprint(energia)
11837         call flush(iout)
11838         write (iout,*) "enter cartgrad"
11839         call flush(iout)
11840         call cartgrad
11841         write (iout,*) "exit cartgrad"
11842         call flush(iout)
11843         icall =1
11844         write (iout,*) "longrange grad"
11845         do i=1,nres
11846           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11847           (gxcart(j,i),j=1,3)
11848         enddo
11849         do j=1,3
11850           grad_s(j,0)=gcart(j,0)
11851         enddo
11852         do i=1,nres
11853           do j=1,3
11854             grad_s(j,i)=gcart(j,i)
11855             grad_s(j+3,i)=gxcart(j,i)
11856           enddo
11857         enddo
11858         call zerograd
11859         call etotal_short(energia)
11860         call enerprint(energia)
11861         call flush(iout)
11862         write (iout,*) "enter cartgrad"
11863         call flush(iout)
11864         call cartgrad
11865         write (iout,*) "exit cartgrad"
11866         call flush(iout)
11867         icall =1
11868         write (iout,*) "shortrange grad"
11869         do i=1,nres
11870           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11871           (gxcart(j,i),j=1,3)
11872         enddo
11873         do j=1,3
11874           grad_s1(j,0)=gcart(j,0)
11875         enddo
11876         do i=1,nres
11877           do j=1,3
11878             grad_s1(j,i)=gcart(j,i)
11879             grad_s1(j+3,i)=gxcart(j,i)
11880           enddo
11881         enddo
11882       endif
11883       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11884 !      do i=1,nres
11885       do i=nnt,nct
11886         do j=1,3
11887           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11888           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11889         ddc(j)=c(j,i)
11890         ddx(j)=c(j,i+nres)
11891           dcnorm_safe1(j)=dc_norm(j,i-1)
11892           dcnorm_safe2(j)=dc_norm(j,i)
11893           dxnorm_safe(j)=dc_norm(j,i+nres)
11894         enddo
11895       do j=1,3
11896         c(j,i)=ddc(j)+aincr
11897           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11898           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11899           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11900           dc(j,i)=c(j,i+1)-c(j,i)
11901           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11902           call int_from_cart1(.false.)
11903           if (.not.split_ene) then
11904             call etotal(energia1)
11905             etot1=energia1(0)
11906             write (iout,*) "ij",i,j," etot1",etot1
11907           else
11908 !- split gradient
11909             call etotal_long(energia1)
11910             etot11=energia1(0)
11911             call etotal_short(energia1)
11912             etot12=energia1(0)
11913           endif
11914 !- end split gradient
11915 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11916         c(j,i)=ddc(j)-aincr
11917           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11918           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11919           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11920           dc(j,i)=c(j,i+1)-c(j,i)
11921           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11922           call int_from_cart1(.false.)
11923           if (.not.split_ene) then
11924             call etotal(energia1)
11925             etot2=energia1(0)
11926             write (iout,*) "ij",i,j," etot2",etot2
11927           ggg(j)=(etot1-etot2)/(2*aincr)
11928           else
11929 !- split gradient
11930             call etotal_long(energia1)
11931             etot21=energia1(0)
11932           ggg(j)=(etot11-etot21)/(2*aincr)
11933             call etotal_short(energia1)
11934             etot22=energia1(0)
11935           ggg1(j)=(etot12-etot22)/(2*aincr)
11936 !- end split gradient
11937 !            write (iout,*) "etot21",etot21," etot22",etot22
11938           endif
11939 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11940         c(j,i)=ddc(j)
11941           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11942           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11943           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11944           dc(j,i)=c(j,i+1)-c(j,i)
11945           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11946           dc_norm(j,i-1)=dcnorm_safe1(j)
11947           dc_norm(j,i)=dcnorm_safe2(j)
11948           dc_norm(j,i+nres)=dxnorm_safe(j)
11949         enddo
11950       do j=1,3
11951         c(j,i+nres)=ddx(j)+aincr
11952           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11953           call int_from_cart1(.false.)
11954           if (.not.split_ene) then
11955             call etotal(energia1)
11956             etot1=energia1(0)
11957           else
11958 !- split gradient
11959             call etotal_long(energia1)
11960             etot11=energia1(0)
11961             call etotal_short(energia1)
11962             etot12=energia1(0)
11963           endif
11964 !- end split gradient
11965         c(j,i+nres)=ddx(j)-aincr
11966           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11967           call int_from_cart1(.false.)
11968           if (.not.split_ene) then
11969             call etotal(energia1)
11970             etot2=energia1(0)
11971           ggg(j+3)=(etot1-etot2)/(2*aincr)
11972           else
11973 !- split gradient
11974             call etotal_long(energia1)
11975             etot21=energia1(0)
11976           ggg(j+3)=(etot11-etot21)/(2*aincr)
11977             call etotal_short(energia1)
11978             etot22=energia1(0)
11979           ggg1(j+3)=(etot12-etot22)/(2*aincr)
11980 !- end split gradient
11981           endif
11982 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11983         c(j,i+nres)=ddx(j)
11984           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11985           dc_norm(j,i+nres)=dxnorm_safe(j)
11986           call int_from_cart1(.false.)
11987         enddo
11988       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11989          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11990         if (split_ene) then
11991           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11992          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11993          k=1,6)
11994          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11995          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11996          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11997         endif
11998       enddo
11999       return
12000       end subroutine check_ecartint
12001 #else
12002 !-----------------------------------------------------------------------------
12003       subroutine check_ecartint
12004 ! Check the gradient of the energy in Cartesian coordinates.
12005       use io_base, only: intout
12006 !      implicit real*8 (a-h,o-z)
12007 !      include 'DIMENSIONS'
12008 !      include 'COMMON.CONTROL'
12009 !      include 'COMMON.CHAIN'
12010 !      include 'COMMON.DERIV'
12011 !      include 'COMMON.IOUNITS'
12012 !      include 'COMMON.VAR'
12013 !      include 'COMMON.CONTACTS'
12014 !      include 'COMMON.MD'
12015 !      include 'COMMON.LOCAL'
12016 !      include 'COMMON.SPLITELE'
12017       use comm_srutu
12018 !el      integer :: icall
12019 !el      common /srutu/ icall
12020       real(kind=8),dimension(6) :: ggg,ggg1
12021       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12022       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12023       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12024       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12025       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12026       real(kind=8),dimension(0:n_ene) :: energia,energia1
12027       integer :: uiparm(1)
12028       real(kind=8) :: urparm(1)
12029 !EL      external fdum
12030       integer :: i,j,k,nf
12031       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12032                    etot21,etot22
12033       r_cut=2.0d0
12034       rlambd=0.3d0
12035       icg=1
12036       nf=0
12037       nfl=0
12038       call intout
12039 !      call intcartderiv
12040 !      call checkintcartgrad
12041       call zerograd
12042       aincr=2.0D-5
12043       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12044       nf=0
12045       icall=0
12046       call geom_to_var(nvar,x)
12047       if (.not.split_ene) then
12048         call etotal(energia)
12049         etot=energia(0)
12050 !el        call enerprint(energia)
12051         call flush(iout)
12052         write (iout,*) "enter cartgrad"
12053         call flush(iout)
12054         call cartgrad
12055         write (iout,*) "exit cartgrad"
12056         call flush(iout)
12057         icall =1
12058         do i=1,nres
12059           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12060         enddo
12061         do j=1,3
12062           grad_s(j,0)=gcart(j,0)
12063         enddo
12064         do i=1,nres
12065           do j=1,3
12066             grad_s(j,i)=gcart(j,i)
12067 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12068             grad_s(j+3,i)=gxcart(j,i)
12069           enddo
12070         enddo
12071       else
12072 !- split gradient check
12073         call zerograd
12074         call etotal_long(energia)
12075 !el        call enerprint(energia)
12076         call flush(iout)
12077         write (iout,*) "enter cartgrad"
12078         call flush(iout)
12079         call cartgrad
12080         write (iout,*) "exit cartgrad"
12081         call flush(iout)
12082         icall =1
12083         write (iout,*) "longrange grad"
12084         do i=1,nres
12085           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12086           (gxcart(j,i),j=1,3)
12087         enddo
12088         do j=1,3
12089           grad_s(j,0)=gcart(j,0)
12090         enddo
12091         do i=1,nres
12092           do j=1,3
12093             grad_s(j,i)=gcart(j,i)
12094             grad_s(j+3,i)=gxcart(j,i)
12095           enddo
12096         enddo
12097         call zerograd
12098         call etotal_short(energia)
12099 !el        call enerprint(energia)
12100         call flush(iout)
12101         write (iout,*) "enter cartgrad"
12102         call flush(iout)
12103         call cartgrad
12104         write (iout,*) "exit cartgrad"
12105         call flush(iout)
12106         icall =1
12107         write (iout,*) "shortrange grad"
12108         do i=1,nres
12109           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12110           (gxcart(j,i),j=1,3)
12111         enddo
12112         do j=1,3
12113           grad_s1(j,0)=gcart(j,0)
12114         enddo
12115         do i=1,nres
12116           do j=1,3
12117             grad_s1(j,i)=gcart(j,i)
12118             grad_s1(j+3,i)=gxcart(j,i)
12119           enddo
12120         enddo
12121       endif
12122       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12123       do i=0,nres
12124         do j=1,3
12125         xx(j)=c(j,i+nres)
12126         ddc(j)=dc(j,i)
12127         ddx(j)=dc(j,i+nres)
12128           do k=1,3
12129             dcnorm_safe(k)=dc_norm(k,i)
12130             dxnorm_safe(k)=dc_norm(k,i+nres)
12131           enddo
12132         enddo
12133       do j=1,3
12134         dc(j,i)=ddc(j)+aincr
12135           call chainbuild_cart
12136 #ifdef MPI
12137 ! Broadcast the order to compute internal coordinates to the slaves.
12138 !          if (nfgtasks.gt.1)
12139 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12140 #endif
12141 !          call int_from_cart1(.false.)
12142           if (.not.split_ene) then
12143             call etotal(energia1)
12144             etot1=energia1(0)
12145 !            call enerprint(energia1)
12146           else
12147 !- split gradient
12148             call etotal_long(energia1)
12149             etot11=energia1(0)
12150             call etotal_short(energia1)
12151             etot12=energia1(0)
12152 !            write (iout,*) "etot11",etot11," etot12",etot12
12153           endif
12154 !- end split gradient
12155 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12156         dc(j,i)=ddc(j)-aincr
12157           call chainbuild_cart
12158 !          call int_from_cart1(.false.)
12159           if (.not.split_ene) then
12160             call etotal(energia1)
12161             etot2=energia1(0)
12162           ggg(j)=(etot1-etot2)/(2*aincr)
12163           else
12164 !- split gradient
12165             call etotal_long(energia1)
12166             etot21=energia1(0)
12167           ggg(j)=(etot11-etot21)/(2*aincr)
12168             call etotal_short(energia1)
12169             etot22=energia1(0)
12170           ggg1(j)=(etot12-etot22)/(2*aincr)
12171 !- end split gradient
12172 !            write (iout,*) "etot21",etot21," etot22",etot22
12173           endif
12174 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12175         dc(j,i)=ddc(j)
12176           call chainbuild_cart
12177         enddo
12178       do j=1,3
12179         dc(j,i+nres)=ddx(j)+aincr
12180           call chainbuild_cart
12181 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12182 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12183 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12184 !          write (iout,*) "dxnormnorm",dsqrt(
12185 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12186 !          write (iout,*) "dxnormnormsafe",dsqrt(
12187 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12188 !          write (iout,*)
12189           if (.not.split_ene) then
12190             call etotal(energia1)
12191             etot1=energia1(0)
12192           else
12193 !- split gradient
12194             call etotal_long(energia1)
12195             etot11=energia1(0)
12196             call etotal_short(energia1)
12197             etot12=energia1(0)
12198           endif
12199 !- end split gradient
12200 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12201         dc(j,i+nres)=ddx(j)-aincr
12202           call chainbuild_cart
12203 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12204 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12205 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12206 !          write (iout,*)
12207 !          write (iout,*) "dxnormnorm",dsqrt(
12208 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12209 !          write (iout,*) "dxnormnormsafe",dsqrt(
12210 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12211           if (.not.split_ene) then
12212             call etotal(energia1)
12213             etot2=energia1(0)
12214           ggg(j+3)=(etot1-etot2)/(2*aincr)
12215           else
12216 !- split gradient
12217             call etotal_long(energia1)
12218             etot21=energia1(0)
12219           ggg(j+3)=(etot11-etot21)/(2*aincr)
12220             call etotal_short(energia1)
12221             etot22=energia1(0)
12222           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12223 !- end split gradient
12224           endif
12225 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12226         dc(j,i+nres)=ddx(j)
12227           call chainbuild_cart
12228         enddo
12229       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12230          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12231         if (split_ene) then
12232           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12233          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12234          k=1,6)
12235          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12236          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12237          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12238         endif
12239       enddo
12240       return
12241       end subroutine check_ecartint
12242 #endif
12243 !-----------------------------------------------------------------------------
12244       subroutine check_eint
12245 ! Check the gradient of energy in internal coordinates.
12246 !      implicit real*8 (a-h,o-z)
12247 !      include 'DIMENSIONS'
12248 !      include 'COMMON.CHAIN'
12249 !      include 'COMMON.DERIV'
12250 !      include 'COMMON.IOUNITS'
12251 !      include 'COMMON.VAR'
12252 !      include 'COMMON.GEO'
12253       use comm_srutu
12254 !el      integer :: icall
12255 !el      common /srutu/ icall
12256       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12257       integer :: uiparm(1)
12258       real(kind=8) :: urparm(1)
12259       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12260       character(len=6) :: key
12261 !EL      external fdum
12262       integer :: i,ii,nf
12263       real(kind=8) :: xi,aincr,etot,etot1,etot2
12264       call zerograd
12265       aincr=1.0D-7
12266       print '(a)','Calling CHECK_INT.'
12267       nf=0
12268       nfl=0
12269       icg=1
12270       call geom_to_var(nvar,x)
12271       call var_to_geom(nvar,x)
12272       call chainbuild
12273       icall=1
12274 !      print *,'ICG=',ICG
12275       call etotal(energia)
12276       etot = energia(0)
12277 !el      call enerprint(energia)
12278 !      print *,'ICG=',ICG
12279 #ifdef MPL
12280       if (MyID.ne.BossID) then
12281         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12282         nf=x(nvar+1)
12283         nfl=x(nvar+2)
12284         icg=x(nvar+3)
12285       endif
12286 #endif
12287       nf=1
12288       nfl=3
12289 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12290       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12291 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12292       icall=1
12293       do i=1,nvar
12294         xi=x(i)
12295         x(i)=xi-0.5D0*aincr
12296         call var_to_geom(nvar,x)
12297         call chainbuild
12298         call etotal(energia1)
12299         etot1=energia1(0)
12300         x(i)=xi+0.5D0*aincr
12301         call var_to_geom(nvar,x)
12302         call chainbuild
12303         call etotal(energia2)
12304         etot2=energia2(0)
12305         gg(i)=(etot2-etot1)/aincr
12306         write (iout,*) i,etot1,etot2
12307         x(i)=xi
12308       enddo
12309       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12310           '     RelDiff*100% '
12311       do i=1,nvar
12312         if (i.le.nphi) then
12313           ii=i
12314           key = ' phi'
12315         else if (i.le.nphi+ntheta) then
12316           ii=i-nphi
12317           key=' theta'
12318         else if (i.le.nphi+ntheta+nside) then
12319            ii=i-(nphi+ntheta)
12320            key=' alpha'
12321         else
12322            ii=i-(nphi+ntheta+nside)
12323            key=' omega'
12324         endif
12325         write (iout,'(i3,a,i3,3(1pd16.6))') &
12326        i,key,ii,gg(i),gana(i),&
12327        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12328       enddo
12329       return
12330       end subroutine check_eint
12331 !-----------------------------------------------------------------------------
12332 ! econstr_local.F
12333 !-----------------------------------------------------------------------------
12334       subroutine Econstr_back
12335 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12336 !      implicit real*8 (a-h,o-z)
12337 !      include 'DIMENSIONS'
12338 !      include 'COMMON.CONTROL'
12339 !      include 'COMMON.VAR'
12340 !      include 'COMMON.MD'
12341       use MD_data
12342 !#ifndef LANG0
12343 !      include 'COMMON.LANGEVIN'
12344 !#else
12345 !      include 'COMMON.LANGEVIN.lang0'
12346 !#endif
12347 !      include 'COMMON.CHAIN'
12348 !      include 'COMMON.DERIV'
12349 !      include 'COMMON.GEO'
12350 !      include 'COMMON.LOCAL'
12351 !      include 'COMMON.INTERACT'
12352 !      include 'COMMON.IOUNITS'
12353 !      include 'COMMON.NAMES'
12354 !      include 'COMMON.TIME1'
12355       integer :: i,j,ii,k
12356       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12357
12358       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12359       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12360       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12361
12362       Uconst_back=0.0d0
12363       do i=1,nres
12364         dutheta(i)=0.0d0
12365         dugamma(i)=0.0d0
12366         do j=1,3
12367           duscdiff(j,i)=0.0d0
12368           duscdiffx(j,i)=0.0d0
12369         enddo
12370       enddo
12371       do i=1,nfrag_back
12372         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12373 !
12374 ! Deviations from theta angles
12375 !
12376         utheta_i=0.0d0
12377         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12378           dtheta_i=theta(j)-thetaref(j)
12379           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12380           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12381         enddo
12382         utheta(i)=utheta_i/(ii-1)
12383 !
12384 ! Deviations from gamma angles
12385 !
12386         ugamma_i=0.0d0
12387         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12388           dgamma_i=pinorm(phi(j)-phiref(j))
12389 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12390           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12391           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12392 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12393         enddo
12394         ugamma(i)=ugamma_i/(ii-2)
12395 !
12396 ! Deviations from local SC geometry
12397 !
12398         uscdiff(i)=0.0d0
12399         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12400           dxx=xxtab(j)-xxref(j)
12401           dyy=yytab(j)-yyref(j)
12402           dzz=zztab(j)-zzref(j)
12403           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12404           do k=1,3
12405             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12406              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12407              (ii-1)
12408             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12409              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12410              (ii-1)
12411             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12412            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12413             /(ii-1)
12414           enddo
12415 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12416 !     &      xxref(j),yyref(j),zzref(j)
12417         enddo
12418         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12419 !        write (iout,*) i," uscdiff",uscdiff(i)
12420 !
12421 ! Put together deviations from local geometry
12422 !
12423         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12424           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12425 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12426 !     &   " uconst_back",uconst_back
12427         utheta(i)=dsqrt(utheta(i))
12428         ugamma(i)=dsqrt(ugamma(i))
12429         uscdiff(i)=dsqrt(uscdiff(i))
12430       enddo
12431       return
12432       end subroutine Econstr_back
12433 !-----------------------------------------------------------------------------
12434 ! energy_p_new-sep_barrier.F
12435 !-----------------------------------------------------------------------------
12436       real(kind=8) function sscale(r)
12437 !      include "COMMON.SPLITELE"
12438       real(kind=8) :: r,gamm
12439       if(r.lt.r_cut-rlamb) then
12440         sscale=1.0d0
12441       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12442         gamm=(r-(r_cut-rlamb))/rlamb
12443         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12444       else
12445         sscale=0d0
12446       endif
12447       return
12448       end function sscale
12449       real(kind=8) function sscale_grad(r)
12450 !      include "COMMON.SPLITELE"
12451       real(kind=8) :: r,gamm
12452       if(r.lt.r_cut-rlamb) then
12453         sscale_grad=0.0d0
12454       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12455         gamm=(r-(r_cut-rlamb))/rlamb
12456         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12457       else
12458         sscale_grad=0d0
12459       endif
12460       return
12461       end function sscale_grad
12462
12463 !!!!!!!!!! PBCSCALE
12464       real(kind=8) function sscale_ele(r)
12465 !      include "COMMON.SPLITELE"
12466       real(kind=8) :: r,gamm
12467       if(r.lt.r_cut_ele-rlamb_ele) then
12468         sscale_ele=1.0d0
12469       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12470         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12471         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12472       else
12473         sscale_ele=0d0
12474       endif
12475       return
12476       end function sscale_ele
12477
12478       real(kind=8)  function sscagrad_ele(r)
12479       real(kind=8) :: r,gamm
12480 !      include "COMMON.SPLITELE"
12481       if(r.lt.r_cut_ele-rlamb_ele) then
12482         sscagrad_ele=0.0d0
12483       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12484         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12485         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12486       else
12487         sscagrad_ele=0.0d0
12488       endif
12489       return
12490       end function sscagrad_ele
12491       real(kind=8) function sscalelip(r)
12492       real(kind=8) r,gamm
12493         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12494       return
12495       end function sscalelip
12496 !C-----------------------------------------------------------------------
12497       real(kind=8) function sscagradlip(r)
12498       real(kind=8) r,gamm
12499         sscagradlip=r*(6.0d0*r-6.0d0)
12500       return
12501       end function sscagradlip
12502
12503 !!!!!!!!!!!!!!!
12504 !-----------------------------------------------------------------------------
12505       subroutine elj_long(evdw)
12506 !
12507 ! This subroutine calculates the interaction energy of nonbonded side chains
12508 ! assuming the LJ potential of interaction.
12509 !
12510 !      implicit real*8 (a-h,o-z)
12511 !      include 'DIMENSIONS'
12512 !      include 'COMMON.GEO'
12513 !      include 'COMMON.VAR'
12514 !      include 'COMMON.LOCAL'
12515 !      include 'COMMON.CHAIN'
12516 !      include 'COMMON.DERIV'
12517 !      include 'COMMON.INTERACT'
12518 !      include 'COMMON.TORSION'
12519 !      include 'COMMON.SBRIDGE'
12520 !      include 'COMMON.NAMES'
12521 !      include 'COMMON.IOUNITS'
12522 !      include 'COMMON.CONTACTS'
12523       real(kind=8),parameter :: accur=1.0d-10
12524       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12525 !el local variables
12526       integer :: i,iint,j,k,itypi,itypi1,itypj
12527       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12528       real(kind=8) :: e1,e2,evdwij,evdw
12529 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12530       evdw=0.0D0
12531       do i=iatsc_s,iatsc_e
12532         itypi=itype(i,1)
12533         if (itypi.eq.ntyp1) cycle
12534         itypi1=itype(i+1,1)
12535         xi=c(1,nres+i)
12536         yi=c(2,nres+i)
12537         zi=c(3,nres+i)
12538 !
12539 ! Calculate SC interaction energy.
12540 !
12541         do iint=1,nint_gr(i)
12542 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12543 !d   &                  'iend=',iend(i,iint)
12544           do j=istart(i,iint),iend(i,iint)
12545             itypj=itype(j,1)
12546             if (itypj.eq.ntyp1) cycle
12547             xj=c(1,nres+j)-xi
12548             yj=c(2,nres+j)-yi
12549             zj=c(3,nres+j)-zi
12550             rij=xj*xj+yj*yj+zj*zj
12551             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12552             if (sss.lt.1.0d0) then
12553               rrij=1.0D0/rij
12554               eps0ij=eps(itypi,itypj)
12555               fac=rrij**expon2
12556               e1=fac*fac*aa_aq(itypi,itypj)
12557               e2=fac*bb_aq(itypi,itypj)
12558               evdwij=e1+e2
12559               evdw=evdw+(1.0d0-sss)*evdwij
12560 !
12561 ! Calculate the components of the gradient in DC and X
12562 !
12563               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12564               gg(1)=xj*fac
12565               gg(2)=yj*fac
12566               gg(3)=zj*fac
12567               do k=1,3
12568                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12569                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12570                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12571                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12572               enddo
12573             endif
12574           enddo      ! j
12575         enddo        ! iint
12576       enddo          ! i
12577       do i=1,nct
12578         do j=1,3
12579           gvdwc(j,i)=expon*gvdwc(j,i)
12580           gvdwx(j,i)=expon*gvdwx(j,i)
12581         enddo
12582       enddo
12583 !******************************************************************************
12584 !
12585 !                              N O T E !!!
12586 !
12587 ! To save time, the factor of EXPON has been extracted from ALL components
12588 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12589 ! use!
12590 !
12591 !******************************************************************************
12592       return
12593       end subroutine elj_long
12594 !-----------------------------------------------------------------------------
12595       subroutine elj_short(evdw)
12596 !
12597 ! This subroutine calculates the interaction energy of nonbonded side chains
12598 ! assuming the LJ potential of interaction.
12599 !
12600 !      implicit real*8 (a-h,o-z)
12601 !      include 'DIMENSIONS'
12602 !      include 'COMMON.GEO'
12603 !      include 'COMMON.VAR'
12604 !      include 'COMMON.LOCAL'
12605 !      include 'COMMON.CHAIN'
12606 !      include 'COMMON.DERIV'
12607 !      include 'COMMON.INTERACT'
12608 !      include 'COMMON.TORSION'
12609 !      include 'COMMON.SBRIDGE'
12610 !      include 'COMMON.NAMES'
12611 !      include 'COMMON.IOUNITS'
12612 !      include 'COMMON.CONTACTS'
12613       real(kind=8),parameter :: accur=1.0d-10
12614       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12615 !el local variables
12616       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12617       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12618       real(kind=8) :: e1,e2,evdwij,evdw
12619 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12620       evdw=0.0D0
12621       do i=iatsc_s,iatsc_e
12622         itypi=itype(i,1)
12623         if (itypi.eq.ntyp1) cycle
12624         itypi1=itype(i+1,1)
12625         xi=c(1,nres+i)
12626         yi=c(2,nres+i)
12627         zi=c(3,nres+i)
12628 ! Change 12/1/95
12629         num_conti=0
12630 !
12631 ! Calculate SC interaction energy.
12632 !
12633         do iint=1,nint_gr(i)
12634 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12635 !d   &                  'iend=',iend(i,iint)
12636           do j=istart(i,iint),iend(i,iint)
12637             itypj=itype(j,1)
12638             if (itypj.eq.ntyp1) cycle
12639             xj=c(1,nres+j)-xi
12640             yj=c(2,nres+j)-yi
12641             zj=c(3,nres+j)-zi
12642 ! Change 12/1/95 to calculate four-body interactions
12643             rij=xj*xj+yj*yj+zj*zj
12644             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12645             if (sss.gt.0.0d0) then
12646               rrij=1.0D0/rij
12647               eps0ij=eps(itypi,itypj)
12648               fac=rrij**expon2
12649               e1=fac*fac*aa_aq(itypi,itypj)
12650               e2=fac*bb_aq(itypi,itypj)
12651               evdwij=e1+e2
12652               evdw=evdw+sss*evdwij
12653 !
12654 ! Calculate the components of the gradient in DC and X
12655 !
12656               fac=-rrij*(e1+evdwij)*sss
12657               gg(1)=xj*fac
12658               gg(2)=yj*fac
12659               gg(3)=zj*fac
12660               do k=1,3
12661                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12662                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12663                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12664                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12665               enddo
12666             endif
12667           enddo      ! j
12668         enddo        ! iint
12669       enddo          ! i
12670       do i=1,nct
12671         do j=1,3
12672           gvdwc(j,i)=expon*gvdwc(j,i)
12673           gvdwx(j,i)=expon*gvdwx(j,i)
12674         enddo
12675       enddo
12676 !******************************************************************************
12677 !
12678 !                              N O T E !!!
12679 !
12680 ! To save time, the factor of EXPON has been extracted from ALL components
12681 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12682 ! use!
12683 !
12684 !******************************************************************************
12685       return
12686       end subroutine elj_short
12687 !-----------------------------------------------------------------------------
12688       subroutine eljk_long(evdw)
12689 !
12690 ! This subroutine calculates the interaction energy of nonbonded side chains
12691 ! assuming the LJK potential of interaction.
12692 !
12693 !      implicit real*8 (a-h,o-z)
12694 !      include 'DIMENSIONS'
12695 !      include 'COMMON.GEO'
12696 !      include 'COMMON.VAR'
12697 !      include 'COMMON.LOCAL'
12698 !      include 'COMMON.CHAIN'
12699 !      include 'COMMON.DERIV'
12700 !      include 'COMMON.INTERACT'
12701 !      include 'COMMON.IOUNITS'
12702 !      include 'COMMON.NAMES'
12703       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12704       logical :: scheck
12705 !el local variables
12706       integer :: i,iint,j,k,itypi,itypi1,itypj
12707       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12708                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12709 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12710       evdw=0.0D0
12711       do i=iatsc_s,iatsc_e
12712         itypi=itype(i,1)
12713         if (itypi.eq.ntyp1) cycle
12714         itypi1=itype(i+1,1)
12715         xi=c(1,nres+i)
12716         yi=c(2,nres+i)
12717         zi=c(3,nres+i)
12718 !
12719 ! Calculate SC interaction energy.
12720 !
12721         do iint=1,nint_gr(i)
12722           do j=istart(i,iint),iend(i,iint)
12723             itypj=itype(j,1)
12724             if (itypj.eq.ntyp1) cycle
12725             xj=c(1,nres+j)-xi
12726             yj=c(2,nres+j)-yi
12727             zj=c(3,nres+j)-zi
12728             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12729             fac_augm=rrij**expon
12730             e_augm=augm(itypi,itypj)*fac_augm
12731             r_inv_ij=dsqrt(rrij)
12732             rij=1.0D0/r_inv_ij
12733             sss=sscale(rij/sigma(itypi,itypj))
12734             if (sss.lt.1.0d0) then
12735               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12736               fac=r_shift_inv**expon
12737               e1=fac*fac*aa_aq(itypi,itypj)
12738               e2=fac*bb_aq(itypi,itypj)
12739               evdwij=e_augm+e1+e2
12740 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12741 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12742 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12743 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12744 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12745 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12746 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12747               evdw=evdw+(1.0d0-sss)*evdwij
12748 !
12749 ! Calculate the components of the gradient in DC and X
12750 !
12751               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12752               fac=fac*(1.0d0-sss)
12753               gg(1)=xj*fac
12754               gg(2)=yj*fac
12755               gg(3)=zj*fac
12756               do k=1,3
12757                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12758                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12759                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12760                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12761               enddo
12762             endif
12763           enddo      ! j
12764         enddo        ! iint
12765       enddo          ! i
12766       do i=1,nct
12767         do j=1,3
12768           gvdwc(j,i)=expon*gvdwc(j,i)
12769           gvdwx(j,i)=expon*gvdwx(j,i)
12770         enddo
12771       enddo
12772       return
12773       end subroutine eljk_long
12774 !-----------------------------------------------------------------------------
12775       subroutine eljk_short(evdw)
12776 !
12777 ! This subroutine calculates the interaction energy of nonbonded side chains
12778 ! assuming the LJK potential of interaction.
12779 !
12780 !      implicit real*8 (a-h,o-z)
12781 !      include 'DIMENSIONS'
12782 !      include 'COMMON.GEO'
12783 !      include 'COMMON.VAR'
12784 !      include 'COMMON.LOCAL'
12785 !      include 'COMMON.CHAIN'
12786 !      include 'COMMON.DERIV'
12787 !      include 'COMMON.INTERACT'
12788 !      include 'COMMON.IOUNITS'
12789 !      include 'COMMON.NAMES'
12790       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12791       logical :: scheck
12792 !el local variables
12793       integer :: i,iint,j,k,itypi,itypi1,itypj
12794       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12795                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12796 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12797       evdw=0.0D0
12798       do i=iatsc_s,iatsc_e
12799         itypi=itype(i,1)
12800         if (itypi.eq.ntyp1) cycle
12801         itypi1=itype(i+1,1)
12802         xi=c(1,nres+i)
12803         yi=c(2,nres+i)
12804         zi=c(3,nres+i)
12805 !
12806 ! Calculate SC interaction energy.
12807 !
12808         do iint=1,nint_gr(i)
12809           do j=istart(i,iint),iend(i,iint)
12810             itypj=itype(j,1)
12811             if (itypj.eq.ntyp1) cycle
12812             xj=c(1,nres+j)-xi
12813             yj=c(2,nres+j)-yi
12814             zj=c(3,nres+j)-zi
12815             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12816             fac_augm=rrij**expon
12817             e_augm=augm(itypi,itypj)*fac_augm
12818             r_inv_ij=dsqrt(rrij)
12819             rij=1.0D0/r_inv_ij
12820             sss=sscale(rij/sigma(itypi,itypj))
12821             if (sss.gt.0.0d0) then
12822               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12823               fac=r_shift_inv**expon
12824               e1=fac*fac*aa_aq(itypi,itypj)
12825               e2=fac*bb_aq(itypi,itypj)
12826               evdwij=e_augm+e1+e2
12827 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12828 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12829 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12830 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12831 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12832 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12833 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12834               evdw=evdw+sss*evdwij
12835 !
12836 ! Calculate the components of the gradient in DC and X
12837 !
12838               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12839               fac=fac*sss
12840               gg(1)=xj*fac
12841               gg(2)=yj*fac
12842               gg(3)=zj*fac
12843               do k=1,3
12844                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12845                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12846                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12847                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12848               enddo
12849             endif
12850           enddo      ! j
12851         enddo        ! iint
12852       enddo          ! i
12853       do i=1,nct
12854         do j=1,3
12855           gvdwc(j,i)=expon*gvdwc(j,i)
12856           gvdwx(j,i)=expon*gvdwx(j,i)
12857         enddo
12858       enddo
12859       return
12860       end subroutine eljk_short
12861 !-----------------------------------------------------------------------------
12862       subroutine ebp_long(evdw)
12863 !
12864 ! This subroutine calculates the interaction energy of nonbonded side chains
12865 ! assuming the Berne-Pechukas potential of interaction.
12866 !
12867       use calc_data
12868 !      implicit real*8 (a-h,o-z)
12869 !      include 'DIMENSIONS'
12870 !      include 'COMMON.GEO'
12871 !      include 'COMMON.VAR'
12872 !      include 'COMMON.LOCAL'
12873 !      include 'COMMON.CHAIN'
12874 !      include 'COMMON.DERIV'
12875 !      include 'COMMON.NAMES'
12876 !      include 'COMMON.INTERACT'
12877 !      include 'COMMON.IOUNITS'
12878 !      include 'COMMON.CALC'
12879       use comm_srutu
12880 !el      integer :: icall
12881 !el      common /srutu/ icall
12882 !     double precision rrsave(maxdim)
12883       logical :: lprn
12884 !el local variables
12885       integer :: iint,itypi,itypi1,itypj
12886       real(kind=8) :: rrij,xi,yi,zi,fac
12887       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12888       evdw=0.0D0
12889 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12890       evdw=0.0D0
12891 !     if (icall.eq.0) then
12892 !       lprn=.true.
12893 !     else
12894         lprn=.false.
12895 !     endif
12896 !el      ind=0
12897       do i=iatsc_s,iatsc_e
12898         itypi=itype(i,1)
12899         if (itypi.eq.ntyp1) cycle
12900         itypi1=itype(i+1,1)
12901         xi=c(1,nres+i)
12902         yi=c(2,nres+i)
12903         zi=c(3,nres+i)
12904         dxi=dc_norm(1,nres+i)
12905         dyi=dc_norm(2,nres+i)
12906         dzi=dc_norm(3,nres+i)
12907 !        dsci_inv=dsc_inv(itypi)
12908         dsci_inv=vbld_inv(i+nres)
12909 !
12910 ! Calculate SC interaction energy.
12911 !
12912         do iint=1,nint_gr(i)
12913           do j=istart(i,iint),iend(i,iint)
12914 !el            ind=ind+1
12915             itypj=itype(j,1)
12916             if (itypj.eq.ntyp1) cycle
12917 !            dscj_inv=dsc_inv(itypj)
12918             dscj_inv=vbld_inv(j+nres)
12919             chi1=chi(itypi,itypj)
12920             chi2=chi(itypj,itypi)
12921             chi12=chi1*chi2
12922             chip1=chip(itypi)
12923             chip2=chip(itypj)
12924             chip12=chip1*chip2
12925             alf1=alp(itypi)
12926             alf2=alp(itypj)
12927             alf12=0.5D0*(alf1+alf2)
12928             xj=c(1,nres+j)-xi
12929             yj=c(2,nres+j)-yi
12930             zj=c(3,nres+j)-zi
12931             dxj=dc_norm(1,nres+j)
12932             dyj=dc_norm(2,nres+j)
12933             dzj=dc_norm(3,nres+j)
12934             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12935             rij=dsqrt(rrij)
12936             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12937
12938             if (sss.lt.1.0d0) then
12939
12940 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12941               call sc_angular
12942 ! Calculate whole angle-dependent part of epsilon and contributions
12943 ! to its derivatives
12944               fac=(rrij*sigsq)**expon2
12945               e1=fac*fac*aa_aq(itypi,itypj)
12946               e2=fac*bb_aq(itypi,itypj)
12947               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12948               eps2der=evdwij*eps3rt
12949               eps3der=evdwij*eps2rt
12950               evdwij=evdwij*eps2rt*eps3rt
12951               evdw=evdw+evdwij*(1.0d0-sss)
12952               if (lprn) then
12953               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12954               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12955 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12956 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12957 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12958 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12959 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12960 !d     &          evdwij
12961               endif
12962 ! Calculate gradient components.
12963               e1=e1*eps1*eps2rt**2*eps3rt**2
12964               fac=-expon*(e1+evdwij)
12965               sigder=fac/sigsq
12966               fac=rrij*fac
12967 ! Calculate radial part of the gradient
12968               gg(1)=xj*fac
12969               gg(2)=yj*fac
12970               gg(3)=zj*fac
12971 ! Calculate the angular part of the gradient and sum add the contributions
12972 ! to the appropriate components of the Cartesian gradient.
12973               call sc_grad_scale(1.0d0-sss)
12974             endif
12975           enddo      ! j
12976         enddo        ! iint
12977       enddo          ! i
12978 !     stop
12979       return
12980       end subroutine ebp_long
12981 !-----------------------------------------------------------------------------
12982       subroutine ebp_short(evdw)
12983 !
12984 ! This subroutine calculates the interaction energy of nonbonded side chains
12985 ! assuming the Berne-Pechukas potential of interaction.
12986 !
12987       use calc_data
12988 !      implicit real*8 (a-h,o-z)
12989 !      include 'DIMENSIONS'
12990 !      include 'COMMON.GEO'
12991 !      include 'COMMON.VAR'
12992 !      include 'COMMON.LOCAL'
12993 !      include 'COMMON.CHAIN'
12994 !      include 'COMMON.DERIV'
12995 !      include 'COMMON.NAMES'
12996 !      include 'COMMON.INTERACT'
12997 !      include 'COMMON.IOUNITS'
12998 !      include 'COMMON.CALC'
12999       use comm_srutu
13000 !el      integer :: icall
13001 !el      common /srutu/ icall
13002 !     double precision rrsave(maxdim)
13003       logical :: lprn
13004 !el local variables
13005       integer :: iint,itypi,itypi1,itypj
13006       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13007       real(kind=8) :: sss,e1,e2,evdw
13008       evdw=0.0D0
13009 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13010       evdw=0.0D0
13011 !     if (icall.eq.0) then
13012 !       lprn=.true.
13013 !     else
13014         lprn=.false.
13015 !     endif
13016 !el      ind=0
13017       do i=iatsc_s,iatsc_e
13018         itypi=itype(i,1)
13019         if (itypi.eq.ntyp1) cycle
13020         itypi1=itype(i+1,1)
13021         xi=c(1,nres+i)
13022         yi=c(2,nres+i)
13023         zi=c(3,nres+i)
13024         dxi=dc_norm(1,nres+i)
13025         dyi=dc_norm(2,nres+i)
13026         dzi=dc_norm(3,nres+i)
13027 !        dsci_inv=dsc_inv(itypi)
13028         dsci_inv=vbld_inv(i+nres)
13029 !
13030 ! Calculate SC interaction energy.
13031 !
13032         do iint=1,nint_gr(i)
13033           do j=istart(i,iint),iend(i,iint)
13034 !el            ind=ind+1
13035             itypj=itype(j,1)
13036             if (itypj.eq.ntyp1) cycle
13037 !            dscj_inv=dsc_inv(itypj)
13038             dscj_inv=vbld_inv(j+nres)
13039             chi1=chi(itypi,itypj)
13040             chi2=chi(itypj,itypi)
13041             chi12=chi1*chi2
13042             chip1=chip(itypi)
13043             chip2=chip(itypj)
13044             chip12=chip1*chip2
13045             alf1=alp(itypi)
13046             alf2=alp(itypj)
13047             alf12=0.5D0*(alf1+alf2)
13048             xj=c(1,nres+j)-xi
13049             yj=c(2,nres+j)-yi
13050             zj=c(3,nres+j)-zi
13051             dxj=dc_norm(1,nres+j)
13052             dyj=dc_norm(2,nres+j)
13053             dzj=dc_norm(3,nres+j)
13054             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13055             rij=dsqrt(rrij)
13056             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13057
13058             if (sss.gt.0.0d0) then
13059
13060 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13061               call sc_angular
13062 ! Calculate whole angle-dependent part of epsilon and contributions
13063 ! to its derivatives
13064               fac=(rrij*sigsq)**expon2
13065               e1=fac*fac*aa_aq(itypi,itypj)
13066               e2=fac*bb_aq(itypi,itypj)
13067               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13068               eps2der=evdwij*eps3rt
13069               eps3der=evdwij*eps2rt
13070               evdwij=evdwij*eps2rt*eps3rt
13071               evdw=evdw+evdwij*sss
13072               if (lprn) then
13073               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13074               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13075 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13076 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13077 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13078 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13079 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13080 !d     &          evdwij
13081               endif
13082 ! Calculate gradient components.
13083               e1=e1*eps1*eps2rt**2*eps3rt**2
13084               fac=-expon*(e1+evdwij)
13085               sigder=fac/sigsq
13086               fac=rrij*fac
13087 ! Calculate radial part of the gradient
13088               gg(1)=xj*fac
13089               gg(2)=yj*fac
13090               gg(3)=zj*fac
13091 ! Calculate the angular part of the gradient and sum add the contributions
13092 ! to the appropriate components of the Cartesian gradient.
13093               call sc_grad_scale(sss)
13094             endif
13095           enddo      ! j
13096         enddo        ! iint
13097       enddo          ! i
13098 !     stop
13099       return
13100       end subroutine ebp_short
13101 !-----------------------------------------------------------------------------
13102       subroutine egb_long(evdw)
13103 !
13104 ! This subroutine calculates the interaction energy of nonbonded side chains
13105 ! assuming the Gay-Berne potential of interaction.
13106 !
13107       use calc_data
13108 !      implicit real*8 (a-h,o-z)
13109 !      include 'DIMENSIONS'
13110 !      include 'COMMON.GEO'
13111 !      include 'COMMON.VAR'
13112 !      include 'COMMON.LOCAL'
13113 !      include 'COMMON.CHAIN'
13114 !      include 'COMMON.DERIV'
13115 !      include 'COMMON.NAMES'
13116 !      include 'COMMON.INTERACT'
13117 !      include 'COMMON.IOUNITS'
13118 !      include 'COMMON.CALC'
13119 !      include 'COMMON.CONTROL'
13120       logical :: lprn
13121 !el local variables
13122       integer :: iint,itypi,itypi1,itypj,subchap
13123       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13124       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13125       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13126                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13127                     ssgradlipi,ssgradlipj
13128
13129
13130       evdw=0.0D0
13131 !cccc      energy_dec=.false.
13132 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13133       evdw=0.0D0
13134       lprn=.false.
13135 !     if (icall.eq.0) lprn=.false.
13136 !el      ind=0
13137       do i=iatsc_s,iatsc_e
13138         itypi=itype(i,1)
13139         if (itypi.eq.ntyp1) cycle
13140         itypi1=itype(i+1,1)
13141         xi=c(1,nres+i)
13142         yi=c(2,nres+i)
13143         zi=c(3,nres+i)
13144           xi=mod(xi,boxxsize)
13145           if (xi.lt.0) xi=xi+boxxsize
13146           yi=mod(yi,boxysize)
13147           if (yi.lt.0) yi=yi+boxysize
13148           zi=mod(zi,boxzsize)
13149           if (zi.lt.0) zi=zi+boxzsize
13150        if ((zi.gt.bordlipbot)    &
13151         .and.(zi.lt.bordliptop)) then
13152 !C the energy transfer exist
13153         if (zi.lt.buflipbot) then
13154 !C what fraction I am in
13155          fracinbuf=1.0d0-    &
13156              ((zi-bordlipbot)/lipbufthick)
13157 !C lipbufthick is thickenes of lipid buffore
13158          sslipi=sscalelip(fracinbuf)
13159          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13160         elseif (zi.gt.bufliptop) then
13161          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13162          sslipi=sscalelip(fracinbuf)
13163          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13164         else
13165          sslipi=1.0d0
13166          ssgradlipi=0.0
13167         endif
13168        else
13169          sslipi=0.0d0
13170          ssgradlipi=0.0
13171        endif
13172
13173         dxi=dc_norm(1,nres+i)
13174         dyi=dc_norm(2,nres+i)
13175         dzi=dc_norm(3,nres+i)
13176 !        dsci_inv=dsc_inv(itypi)
13177         dsci_inv=vbld_inv(i+nres)
13178 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13179 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13180 !
13181 ! Calculate SC interaction energy.
13182 !
13183         do iint=1,nint_gr(i)
13184           do j=istart(i,iint),iend(i,iint)
13185             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13186 !              call dyn_ssbond_ene(i,j,evdwij)
13187 !              evdw=evdw+evdwij
13188 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13189 !                              'evdw',i,j,evdwij,' ss'
13190 !              if (energy_dec) write (iout,*) &
13191 !                              'evdw',i,j,evdwij,' ss'
13192 !             do k=j+1,iend(i,iint)
13193 !C search over all next residues
13194 !              if (dyn_ss_mask(k)) then
13195 !C check if they are cysteins
13196 !C              write(iout,*) 'k=',k
13197
13198 !c              write(iout,*) "PRZED TRI", evdwij
13199 !               evdwij_przed_tri=evdwij
13200 !              call triple_ssbond_ene(i,j,k,evdwij)
13201 !c               if(evdwij_przed_tri.ne.evdwij) then
13202 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13203 !c               endif
13204
13205 !c              write(iout,*) "PO TRI", evdwij
13206 !C call the energy function that removes the artifical triple disulfide
13207 !C bond the soubroutine is located in ssMD.F
13208 !              evdw=evdw+evdwij
13209               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13210                             'evdw',i,j,evdwij,'tss'
13211 !              endif!dyn_ss_mask(k)
13212 !             enddo! k
13213
13214             ELSE
13215 !el            ind=ind+1
13216             itypj=itype(j,1)
13217             if (itypj.eq.ntyp1) cycle
13218 !            dscj_inv=dsc_inv(itypj)
13219             dscj_inv=vbld_inv(j+nres)
13220 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13221 !     &       1.0d0/vbld(j+nres)
13222 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13223             sig0ij=sigma(itypi,itypj)
13224             chi1=chi(itypi,itypj)
13225             chi2=chi(itypj,itypi)
13226             chi12=chi1*chi2
13227             chip1=chip(itypi)
13228             chip2=chip(itypj)
13229             chip12=chip1*chip2
13230             alf1=alp(itypi)
13231             alf2=alp(itypj)
13232             alf12=0.5D0*(alf1+alf2)
13233             xj=c(1,nres+j)
13234             yj=c(2,nres+j)
13235             zj=c(3,nres+j)
13236 ! Searching for nearest neighbour
13237           xj=mod(xj,boxxsize)
13238           if (xj.lt.0) xj=xj+boxxsize
13239           yj=mod(yj,boxysize)
13240           if (yj.lt.0) yj=yj+boxysize
13241           zj=mod(zj,boxzsize)
13242           if (zj.lt.0) zj=zj+boxzsize
13243        if ((zj.gt.bordlipbot)   &
13244       .and.(zj.lt.bordliptop)) then
13245 !C the energy transfer exist
13246         if (zj.lt.buflipbot) then
13247 !C what fraction I am in
13248          fracinbuf=1.0d0-  &
13249              ((zj-bordlipbot)/lipbufthick)
13250 !C lipbufthick is thickenes of lipid buffore
13251          sslipj=sscalelip(fracinbuf)
13252          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13253         elseif (zj.gt.bufliptop) then
13254          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13255          sslipj=sscalelip(fracinbuf)
13256          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13257         else
13258          sslipj=1.0d0
13259          ssgradlipj=0.0
13260         endif
13261        else
13262          sslipj=0.0d0
13263          ssgradlipj=0.0
13264        endif
13265       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13266        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13267       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13268        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13269
13270           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13271           xj_safe=xj
13272           yj_safe=yj
13273           zj_safe=zj
13274           subchap=0
13275           do xshift=-1,1
13276           do yshift=-1,1
13277           do zshift=-1,1
13278           xj=xj_safe+xshift*boxxsize
13279           yj=yj_safe+yshift*boxysize
13280           zj=zj_safe+zshift*boxzsize
13281           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13282           if(dist_temp.lt.dist_init) then
13283             dist_init=dist_temp
13284             xj_temp=xj
13285             yj_temp=yj
13286             zj_temp=zj
13287             subchap=1
13288           endif
13289           enddo
13290           enddo
13291           enddo
13292           if (subchap.eq.1) then
13293           xj=xj_temp-xi
13294           yj=yj_temp-yi
13295           zj=zj_temp-zi
13296           else
13297           xj=xj_safe-xi
13298           yj=yj_safe-yi
13299           zj=zj_safe-zi
13300           endif
13301
13302             dxj=dc_norm(1,nres+j)
13303             dyj=dc_norm(2,nres+j)
13304             dzj=dc_norm(3,nres+j)
13305             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13306             rij=dsqrt(rrij)
13307             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13308             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13309             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13310             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13311             if (sss_ele_cut.le.0.0) cycle
13312             if (sss.lt.1.0d0) then
13313
13314 ! Calculate angle-dependent terms of energy and contributions to their
13315 ! derivatives.
13316               call sc_angular
13317               sigsq=1.0D0/sigsq
13318               sig=sig0ij*dsqrt(sigsq)
13319               rij_shift=1.0D0/rij-sig+sig0ij
13320 ! for diagnostics; uncomment
13321 !              rij_shift=1.2*sig0ij
13322 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13323               if (rij_shift.le.0.0D0) then
13324                 evdw=1.0D20
13325 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13326 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13327 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13328                 return
13329               endif
13330               sigder=-sig*sigsq
13331 !---------------------------------------------------------------
13332               rij_shift=1.0D0/rij_shift
13333               fac=rij_shift**expon
13334               e1=fac*fac*aa
13335               e2=fac*bb
13336               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13337               eps2der=evdwij*eps3rt
13338               eps3der=evdwij*eps2rt
13339 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13340 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13341               evdwij=evdwij*eps2rt*eps3rt
13342               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13343               if (lprn) then
13344               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13345               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13346               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13347                 restyp(itypi,1),i,restyp(itypj,1),j,&
13348                 epsi,sigm,chi1,chi2,chip1,chip2,&
13349                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13350                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13351                 evdwij
13352               endif
13353
13354               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13355                               'evdw',i,j,evdwij
13356 !              if (energy_dec) write (iout,*) &
13357 !                              'evdw',i,j,evdwij,"egb_long"
13358
13359 ! Calculate gradient components.
13360               e1=e1*eps1*eps2rt**2*eps3rt**2
13361               fac=-expon*(e1+evdwij)*rij_shift
13362               sigder=fac*sigder
13363               fac=rij*fac
13364               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13365             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13366             /sigmaii(itypi,itypj))
13367 !              fac=0.0d0
13368 ! Calculate the radial part of the gradient
13369               gg(1)=xj*fac
13370               gg(2)=yj*fac
13371               gg(3)=zj*fac
13372 ! Calculate angular part of the gradient.
13373               call sc_grad_scale(1.0d0-sss)
13374             ENDIF    !mask_dyn_ss
13375             endif
13376           enddo      ! j
13377         enddo        ! iint
13378       enddo          ! i
13379 !      write (iout,*) "Number of loop steps in EGB:",ind
13380 !ccc      energy_dec=.false.
13381       return
13382       end subroutine egb_long
13383 !-----------------------------------------------------------------------------
13384       subroutine egb_short(evdw)
13385 !
13386 ! This subroutine calculates the interaction energy of nonbonded side chains
13387 ! assuming the Gay-Berne potential of interaction.
13388 !
13389       use calc_data
13390 !      implicit real*8 (a-h,o-z)
13391 !      include 'DIMENSIONS'
13392 !      include 'COMMON.GEO'
13393 !      include 'COMMON.VAR'
13394 !      include 'COMMON.LOCAL'
13395 !      include 'COMMON.CHAIN'
13396 !      include 'COMMON.DERIV'
13397 !      include 'COMMON.NAMES'
13398 !      include 'COMMON.INTERACT'
13399 !      include 'COMMON.IOUNITS'
13400 !      include 'COMMON.CALC'
13401 !      include 'COMMON.CONTROL'
13402       logical :: lprn
13403 !el local variables
13404       integer :: iint,itypi,itypi1,itypj,subchap
13405       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13406       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13407       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13408                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13409                     ssgradlipi,ssgradlipj
13410       evdw=0.0D0
13411 !cccc      energy_dec=.false.
13412 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13413       evdw=0.0D0
13414       lprn=.false.
13415 !     if (icall.eq.0) lprn=.false.
13416 !el      ind=0
13417       do i=iatsc_s,iatsc_e
13418         itypi=itype(i,1)
13419         if (itypi.eq.ntyp1) cycle
13420         itypi1=itype(i+1,1)
13421         xi=c(1,nres+i)
13422         yi=c(2,nres+i)
13423         zi=c(3,nres+i)
13424           xi=mod(xi,boxxsize)
13425           if (xi.lt.0) xi=xi+boxxsize
13426           yi=mod(yi,boxysize)
13427           if (yi.lt.0) yi=yi+boxysize
13428           zi=mod(zi,boxzsize)
13429           if (zi.lt.0) zi=zi+boxzsize
13430        if ((zi.gt.bordlipbot)    &
13431         .and.(zi.lt.bordliptop)) then
13432 !C the energy transfer exist
13433         if (zi.lt.buflipbot) then
13434 !C what fraction I am in
13435          fracinbuf=1.0d0-    &
13436              ((zi-bordlipbot)/lipbufthick)
13437 !C lipbufthick is thickenes of lipid buffore
13438          sslipi=sscalelip(fracinbuf)
13439          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13440         elseif (zi.gt.bufliptop) then
13441          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13442          sslipi=sscalelip(fracinbuf)
13443          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13444         else
13445          sslipi=1.0d0
13446          ssgradlipi=0.0
13447         endif
13448        else
13449          sslipi=0.0d0
13450          ssgradlipi=0.0
13451        endif
13452
13453         dxi=dc_norm(1,nres+i)
13454         dyi=dc_norm(2,nres+i)
13455         dzi=dc_norm(3,nres+i)
13456 !        dsci_inv=dsc_inv(itypi)
13457         dsci_inv=vbld_inv(i+nres)
13458
13459         dxi=dc_norm(1,nres+i)
13460         dyi=dc_norm(2,nres+i)
13461         dzi=dc_norm(3,nres+i)
13462 !        dsci_inv=dsc_inv(itypi)
13463         dsci_inv=vbld_inv(i+nres)
13464 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13465 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13466 !
13467 ! Calculate SC interaction energy.
13468 !
13469         do iint=1,nint_gr(i)
13470           do j=istart(i,iint),iend(i,iint)
13471             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13472               call dyn_ssbond_ene(i,j,evdwij)
13473               evdw=evdw+evdwij
13474               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13475                               'evdw',i,j,evdwij,' ss'
13476              do k=j+1,iend(i,iint)
13477 !C search over all next residues
13478               if (dyn_ss_mask(k)) then
13479 !C check if they are cysteins
13480 !C              write(iout,*) 'k=',k
13481
13482 !c              write(iout,*) "PRZED TRI", evdwij
13483 !               evdwij_przed_tri=evdwij
13484               call triple_ssbond_ene(i,j,k,evdwij)
13485 !c               if(evdwij_przed_tri.ne.evdwij) then
13486 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13487 !c               endif
13488
13489 !c              write(iout,*) "PO TRI", evdwij
13490 !C call the energy function that removes the artifical triple disulfide
13491 !C bond the soubroutine is located in ssMD.F
13492               evdw=evdw+evdwij
13493               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13494                             'evdw',i,j,evdwij,'tss'
13495               endif!dyn_ss_mask(k)
13496              enddo! k
13497
13498 !              if (energy_dec) write (iout,*) &
13499 !                              'evdw',i,j,evdwij,' ss'
13500             ELSE
13501 !el            ind=ind+1
13502             itypj=itype(j,1)
13503             if (itypj.eq.ntyp1) cycle
13504 !            dscj_inv=dsc_inv(itypj)
13505             dscj_inv=vbld_inv(j+nres)
13506 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13507 !     &       1.0d0/vbld(j+nres)
13508 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13509             sig0ij=sigma(itypi,itypj)
13510             chi1=chi(itypi,itypj)
13511             chi2=chi(itypj,itypi)
13512             chi12=chi1*chi2
13513             chip1=chip(itypi)
13514             chip2=chip(itypj)
13515             chip12=chip1*chip2
13516             alf1=alp(itypi)
13517             alf2=alp(itypj)
13518             alf12=0.5D0*(alf1+alf2)
13519 !            xj=c(1,nres+j)-xi
13520 !            yj=c(2,nres+j)-yi
13521 !            zj=c(3,nres+j)-zi
13522             xj=c(1,nres+j)
13523             yj=c(2,nres+j)
13524             zj=c(3,nres+j)
13525 ! Searching for nearest neighbour
13526           xj=mod(xj,boxxsize)
13527           if (xj.lt.0) xj=xj+boxxsize
13528           yj=mod(yj,boxysize)
13529           if (yj.lt.0) yj=yj+boxysize
13530           zj=mod(zj,boxzsize)
13531           if (zj.lt.0) zj=zj+boxzsize
13532        if ((zj.gt.bordlipbot)   &
13533       .and.(zj.lt.bordliptop)) then
13534 !C the energy transfer exist
13535         if (zj.lt.buflipbot) then
13536 !C what fraction I am in
13537          fracinbuf=1.0d0-  &
13538              ((zj-bordlipbot)/lipbufthick)
13539 !C lipbufthick is thickenes of lipid buffore
13540          sslipj=sscalelip(fracinbuf)
13541          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13542         elseif (zj.gt.bufliptop) then
13543          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13544          sslipj=sscalelip(fracinbuf)
13545          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13546         else
13547          sslipj=1.0d0
13548          ssgradlipj=0.0
13549         endif
13550        else
13551          sslipj=0.0d0
13552          ssgradlipj=0.0
13553        endif
13554       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13555        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13556       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13557        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13558
13559           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13560           xj_safe=xj
13561           yj_safe=yj
13562           zj_safe=zj
13563           subchap=0
13564
13565           do xshift=-1,1
13566           do yshift=-1,1
13567           do zshift=-1,1
13568           xj=xj_safe+xshift*boxxsize
13569           yj=yj_safe+yshift*boxysize
13570           zj=zj_safe+zshift*boxzsize
13571           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13572           if(dist_temp.lt.dist_init) then
13573             dist_init=dist_temp
13574             xj_temp=xj
13575             yj_temp=yj
13576             zj_temp=zj
13577             subchap=1
13578           endif
13579           enddo
13580           enddo
13581           enddo
13582           if (subchap.eq.1) then
13583           xj=xj_temp-xi
13584           yj=yj_temp-yi
13585           zj=zj_temp-zi
13586           else
13587           xj=xj_safe-xi
13588           yj=yj_safe-yi
13589           zj=zj_safe-zi
13590           endif
13591
13592             dxj=dc_norm(1,nres+j)
13593             dyj=dc_norm(2,nres+j)
13594             dzj=dc_norm(3,nres+j)
13595             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13596             rij=dsqrt(rrij)
13597             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13598             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13599             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13600             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13601             if (sss_ele_cut.le.0.0) cycle
13602
13603             if (sss.gt.0.0d0) then
13604
13605 ! Calculate angle-dependent terms of energy and contributions to their
13606 ! derivatives.
13607               call sc_angular
13608               sigsq=1.0D0/sigsq
13609               sig=sig0ij*dsqrt(sigsq)
13610               rij_shift=1.0D0/rij-sig+sig0ij
13611 ! for diagnostics; uncomment
13612 !              rij_shift=1.2*sig0ij
13613 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13614               if (rij_shift.le.0.0D0) then
13615                 evdw=1.0D20
13616 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13617 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13618 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13619                 return
13620               endif
13621               sigder=-sig*sigsq
13622 !---------------------------------------------------------------
13623               rij_shift=1.0D0/rij_shift
13624               fac=rij_shift**expon
13625               e1=fac*fac*aa
13626               e2=fac*bb
13627               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13628               eps2der=evdwij*eps3rt
13629               eps3der=evdwij*eps2rt
13630 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13631 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13632               evdwij=evdwij*eps2rt*eps3rt
13633               evdw=evdw+evdwij*sss*sss_ele_cut
13634               if (lprn) then
13635               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13636               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13637               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13638                 restyp(itypi,1),i,restyp(itypj,1),j,&
13639                 epsi,sigm,chi1,chi2,chip1,chip2,&
13640                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13641                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13642                 evdwij
13643               endif
13644
13645               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13646                               'evdw',i,j,evdwij
13647 !              if (energy_dec) write (iout,*) &
13648 !                              'evdw',i,j,evdwij,"egb_short"
13649
13650 ! Calculate gradient components.
13651               e1=e1*eps1*eps2rt**2*eps3rt**2
13652               fac=-expon*(e1+evdwij)*rij_shift
13653               sigder=fac*sigder
13654               fac=rij*fac
13655               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13656             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13657             /sigmaii(itypi,itypj))
13658
13659 !              fac=0.0d0
13660 ! Calculate the radial part of the gradient
13661               gg(1)=xj*fac
13662               gg(2)=yj*fac
13663               gg(3)=zj*fac
13664 ! Calculate angular part of the gradient.
13665               call sc_grad_scale(sss)
13666             endif
13667           ENDIF !mask_dyn_ss
13668           enddo      ! j
13669         enddo        ! iint
13670       enddo          ! i
13671 !      write (iout,*) "Number of loop steps in EGB:",ind
13672 !ccc      energy_dec=.false.
13673       return
13674       end subroutine egb_short
13675 !-----------------------------------------------------------------------------
13676       subroutine egbv_long(evdw)
13677 !
13678 ! This subroutine calculates the interaction energy of nonbonded side chains
13679 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13680 !
13681       use calc_data
13682 !      implicit real*8 (a-h,o-z)
13683 !      include 'DIMENSIONS'
13684 !      include 'COMMON.GEO'
13685 !      include 'COMMON.VAR'
13686 !      include 'COMMON.LOCAL'
13687 !      include 'COMMON.CHAIN'
13688 !      include 'COMMON.DERIV'
13689 !      include 'COMMON.NAMES'
13690 !      include 'COMMON.INTERACT'
13691 !      include 'COMMON.IOUNITS'
13692 !      include 'COMMON.CALC'
13693       use comm_srutu
13694 !el      integer :: icall
13695 !el      common /srutu/ icall
13696       logical :: lprn
13697 !el local variables
13698       integer :: iint,itypi,itypi1,itypj
13699       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13700       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13701       evdw=0.0D0
13702 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13703       evdw=0.0D0
13704       lprn=.false.
13705 !     if (icall.eq.0) lprn=.true.
13706 !el      ind=0
13707       do i=iatsc_s,iatsc_e
13708         itypi=itype(i,1)
13709         if (itypi.eq.ntyp1) cycle
13710         itypi1=itype(i+1,1)
13711         xi=c(1,nres+i)
13712         yi=c(2,nres+i)
13713         zi=c(3,nres+i)
13714         dxi=dc_norm(1,nres+i)
13715         dyi=dc_norm(2,nres+i)
13716         dzi=dc_norm(3,nres+i)
13717 !        dsci_inv=dsc_inv(itypi)
13718         dsci_inv=vbld_inv(i+nres)
13719 !
13720 ! Calculate SC interaction energy.
13721 !
13722         do iint=1,nint_gr(i)
13723           do j=istart(i,iint),iend(i,iint)
13724 !el            ind=ind+1
13725             itypj=itype(j,1)
13726             if (itypj.eq.ntyp1) cycle
13727 !            dscj_inv=dsc_inv(itypj)
13728             dscj_inv=vbld_inv(j+nres)
13729             sig0ij=sigma(itypi,itypj)
13730             r0ij=r0(itypi,itypj)
13731             chi1=chi(itypi,itypj)
13732             chi2=chi(itypj,itypi)
13733             chi12=chi1*chi2
13734             chip1=chip(itypi)
13735             chip2=chip(itypj)
13736             chip12=chip1*chip2
13737             alf1=alp(itypi)
13738             alf2=alp(itypj)
13739             alf12=0.5D0*(alf1+alf2)
13740             xj=c(1,nres+j)-xi
13741             yj=c(2,nres+j)-yi
13742             zj=c(3,nres+j)-zi
13743             dxj=dc_norm(1,nres+j)
13744             dyj=dc_norm(2,nres+j)
13745             dzj=dc_norm(3,nres+j)
13746             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13747             rij=dsqrt(rrij)
13748
13749             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13750
13751             if (sss.lt.1.0d0) then
13752
13753 ! Calculate angle-dependent terms of energy and contributions to their
13754 ! derivatives.
13755               call sc_angular
13756               sigsq=1.0D0/sigsq
13757               sig=sig0ij*dsqrt(sigsq)
13758               rij_shift=1.0D0/rij-sig+r0ij
13759 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13760               if (rij_shift.le.0.0D0) then
13761                 evdw=1.0D20
13762                 return
13763               endif
13764               sigder=-sig*sigsq
13765 !---------------------------------------------------------------
13766               rij_shift=1.0D0/rij_shift
13767               fac=rij_shift**expon
13768               e1=fac*fac*aa_aq(itypi,itypj)
13769               e2=fac*bb_aq(itypi,itypj)
13770               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13771               eps2der=evdwij*eps3rt
13772               eps3der=evdwij*eps2rt
13773               fac_augm=rrij**expon
13774               e_augm=augm(itypi,itypj)*fac_augm
13775               evdwij=evdwij*eps2rt*eps3rt
13776               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13777               if (lprn) then
13778               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13779               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13780               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13781                 restyp(itypi,1),i,restyp(itypj,1),j,&
13782                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13783                 chi1,chi2,chip1,chip2,&
13784                 eps1,eps2rt**2,eps3rt**2,&
13785                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13786                 evdwij+e_augm
13787               endif
13788 ! Calculate gradient components.
13789               e1=e1*eps1*eps2rt**2*eps3rt**2
13790               fac=-expon*(e1+evdwij)*rij_shift
13791               sigder=fac*sigder
13792               fac=rij*fac-2*expon*rrij*e_augm
13793 ! Calculate the radial part of the gradient
13794               gg(1)=xj*fac
13795               gg(2)=yj*fac
13796               gg(3)=zj*fac
13797 ! Calculate angular part of the gradient.
13798               call sc_grad_scale(1.0d0-sss)
13799             endif
13800           enddo      ! j
13801         enddo        ! iint
13802       enddo          ! i
13803       end subroutine egbv_long
13804 !-----------------------------------------------------------------------------
13805       subroutine egbv_short(evdw)
13806 !
13807 ! This subroutine calculates the interaction energy of nonbonded side chains
13808 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13809 !
13810       use calc_data
13811 !      implicit real*8 (a-h,o-z)
13812 !      include 'DIMENSIONS'
13813 !      include 'COMMON.GEO'
13814 !      include 'COMMON.VAR'
13815 !      include 'COMMON.LOCAL'
13816 !      include 'COMMON.CHAIN'
13817 !      include 'COMMON.DERIV'
13818 !      include 'COMMON.NAMES'
13819 !      include 'COMMON.INTERACT'
13820 !      include 'COMMON.IOUNITS'
13821 !      include 'COMMON.CALC'
13822       use comm_srutu
13823 !el      integer :: icall
13824 !el      common /srutu/ icall
13825       logical :: lprn
13826 !el local variables
13827       integer :: iint,itypi,itypi1,itypj
13828       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13829       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13830       evdw=0.0D0
13831 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13832       evdw=0.0D0
13833       lprn=.false.
13834 !     if (icall.eq.0) lprn=.true.
13835 !el      ind=0
13836       do i=iatsc_s,iatsc_e
13837         itypi=itype(i,1)
13838         if (itypi.eq.ntyp1) cycle
13839         itypi1=itype(i+1,1)
13840         xi=c(1,nres+i)
13841         yi=c(2,nres+i)
13842         zi=c(3,nres+i)
13843         dxi=dc_norm(1,nres+i)
13844         dyi=dc_norm(2,nres+i)
13845         dzi=dc_norm(3,nres+i)
13846 !        dsci_inv=dsc_inv(itypi)
13847         dsci_inv=vbld_inv(i+nres)
13848 !
13849 ! Calculate SC interaction energy.
13850 !
13851         do iint=1,nint_gr(i)
13852           do j=istart(i,iint),iend(i,iint)
13853 !el            ind=ind+1
13854             itypj=itype(j,1)
13855             if (itypj.eq.ntyp1) cycle
13856 !            dscj_inv=dsc_inv(itypj)
13857             dscj_inv=vbld_inv(j+nres)
13858             sig0ij=sigma(itypi,itypj)
13859             r0ij=r0(itypi,itypj)
13860             chi1=chi(itypi,itypj)
13861             chi2=chi(itypj,itypi)
13862             chi12=chi1*chi2
13863             chip1=chip(itypi)
13864             chip2=chip(itypj)
13865             chip12=chip1*chip2
13866             alf1=alp(itypi)
13867             alf2=alp(itypj)
13868             alf12=0.5D0*(alf1+alf2)
13869             xj=c(1,nres+j)-xi
13870             yj=c(2,nres+j)-yi
13871             zj=c(3,nres+j)-zi
13872             dxj=dc_norm(1,nres+j)
13873             dyj=dc_norm(2,nres+j)
13874             dzj=dc_norm(3,nres+j)
13875             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13876             rij=dsqrt(rrij)
13877
13878             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13879
13880             if (sss.gt.0.0d0) then
13881
13882 ! Calculate angle-dependent terms of energy and contributions to their
13883 ! derivatives.
13884               call sc_angular
13885               sigsq=1.0D0/sigsq
13886               sig=sig0ij*dsqrt(sigsq)
13887               rij_shift=1.0D0/rij-sig+r0ij
13888 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13889               if (rij_shift.le.0.0D0) then
13890                 evdw=1.0D20
13891                 return
13892               endif
13893               sigder=-sig*sigsq
13894 !---------------------------------------------------------------
13895               rij_shift=1.0D0/rij_shift
13896               fac=rij_shift**expon
13897               e1=fac*fac*aa_aq(itypi,itypj)
13898               e2=fac*bb_aq(itypi,itypj)
13899               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13900               eps2der=evdwij*eps3rt
13901               eps3der=evdwij*eps2rt
13902               fac_augm=rrij**expon
13903               e_augm=augm(itypi,itypj)*fac_augm
13904               evdwij=evdwij*eps2rt*eps3rt
13905               evdw=evdw+(evdwij+e_augm)*sss
13906               if (lprn) then
13907               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13908               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13909               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13910                 restyp(itypi,1),i,restyp(itypj,1),j,&
13911                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13912                 chi1,chi2,chip1,chip2,&
13913                 eps1,eps2rt**2,eps3rt**2,&
13914                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13915                 evdwij+e_augm
13916               endif
13917 ! Calculate gradient components.
13918               e1=e1*eps1*eps2rt**2*eps3rt**2
13919               fac=-expon*(e1+evdwij)*rij_shift
13920               sigder=fac*sigder
13921               fac=rij*fac-2*expon*rrij*e_augm
13922 ! Calculate the radial part of the gradient
13923               gg(1)=xj*fac
13924               gg(2)=yj*fac
13925               gg(3)=zj*fac
13926 ! Calculate angular part of the gradient.
13927               call sc_grad_scale(sss)
13928             endif
13929           enddo      ! j
13930         enddo        ! iint
13931       enddo          ! i
13932       end subroutine egbv_short
13933 !-----------------------------------------------------------------------------
13934       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13935 !
13936 ! This subroutine calculates the average interaction energy and its gradient
13937 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13938 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13939 ! The potential depends both on the distance of peptide-group centers and on
13940 ! the orientation of the CA-CA virtual bonds.
13941 !
13942 !      implicit real*8 (a-h,o-z)
13943
13944       use comm_locel
13945 #ifdef MPI
13946       include 'mpif.h'
13947 #endif
13948 !      include 'DIMENSIONS'
13949 !      include 'COMMON.CONTROL'
13950 !      include 'COMMON.SETUP'
13951 !      include 'COMMON.IOUNITS'
13952 !      include 'COMMON.GEO'
13953 !      include 'COMMON.VAR'
13954 !      include 'COMMON.LOCAL'
13955 !      include 'COMMON.CHAIN'
13956 !      include 'COMMON.DERIV'
13957 !      include 'COMMON.INTERACT'
13958 !      include 'COMMON.CONTACTS'
13959 !      include 'COMMON.TORSION'
13960 !      include 'COMMON.VECTORS'
13961 !      include 'COMMON.FFIELD'
13962 !      include 'COMMON.TIME1'
13963       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13964       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13965       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13966 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13967       real(kind=8),dimension(4) :: muij
13968 !el      integer :: num_conti,j1,j2
13969 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13970 !el                   dz_normi,xmedi,ymedi,zmedi
13971 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13972 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13973 !el          num_conti,j1,j2
13974 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13975 #ifdef MOMENT
13976       real(kind=8) :: scal_el=1.0d0
13977 #else
13978       real(kind=8) :: scal_el=0.5d0
13979 #endif
13980 ! 12/13/98
13981 ! 13-go grudnia roku pamietnego...
13982       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13983                                              0.0d0,1.0d0,0.0d0,&
13984                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13985 !el local variables
13986       integer :: i,j,k
13987       real(kind=8) :: fac
13988       real(kind=8) :: dxj,dyj,dzj
13989       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13990
13991 !      allocate(num_cont_hb(nres)) !(maxres)
13992 !d      write(iout,*) 'In EELEC'
13993 !d      do i=1,nloctyp
13994 !d        write(iout,*) 'Type',i
13995 !d        write(iout,*) 'B1',B1(:,i)
13996 !d        write(iout,*) 'B2',B2(:,i)
13997 !d        write(iout,*) 'CC',CC(:,:,i)
13998 !d        write(iout,*) 'DD',DD(:,:,i)
13999 !d        write(iout,*) 'EE',EE(:,:,i)
14000 !d      enddo
14001 !d      call check_vecgrad
14002 !d      stop
14003       if (icheckgrad.eq.1) then
14004         do i=1,nres-1
14005           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14006           do k=1,3
14007             dc_norm(k,i)=dc(k,i)*fac
14008           enddo
14009 !          write (iout,*) 'i',i,' fac',fac
14010         enddo
14011       endif
14012       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14013           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14014           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14015 !        call vec_and_deriv
14016 #ifdef TIMING
14017         time01=MPI_Wtime()
14018 #endif
14019 !        print *, "before set matrices"
14020         call set_matrices
14021 !        print *,"after set martices"
14022 #ifdef TIMING
14023         time_mat=time_mat+MPI_Wtime()-time01
14024 #endif
14025       endif
14026 !d      do i=1,nres-1
14027 !d        write (iout,*) 'i=',i
14028 !d        do k=1,3
14029 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14030 !d        enddo
14031 !d        do k=1,3
14032 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14033 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14034 !d        enddo
14035 !d      enddo
14036       t_eelecij=0.0d0
14037       ees=0.0D0
14038       evdw1=0.0D0
14039       eel_loc=0.0d0
14040       eello_turn3=0.0d0
14041       eello_turn4=0.0d0
14042 !el      ind=0
14043       do i=1,nres
14044         num_cont_hb(i)=0
14045       enddo
14046 !d      print '(a)','Enter EELEC'
14047 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14048 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14049 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14050       do i=1,nres
14051         gel_loc_loc(i)=0.0d0
14052         gcorr_loc(i)=0.0d0
14053       enddo
14054 !
14055 !
14056 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14057 !
14058 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14059 !
14060       do i=iturn3_start,iturn3_end
14061         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14062         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14063         dxi=dc(1,i)
14064         dyi=dc(2,i)
14065         dzi=dc(3,i)
14066         dx_normi=dc_norm(1,i)
14067         dy_normi=dc_norm(2,i)
14068         dz_normi=dc_norm(3,i)
14069         xmedi=c(1,i)+0.5d0*dxi
14070         ymedi=c(2,i)+0.5d0*dyi
14071         zmedi=c(3,i)+0.5d0*dzi
14072           xmedi=dmod(xmedi,boxxsize)
14073           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14074           ymedi=dmod(ymedi,boxysize)
14075           if (ymedi.lt.0) ymedi=ymedi+boxysize
14076           zmedi=dmod(zmedi,boxzsize)
14077           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14078         num_conti=0
14079         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14080         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14081         num_cont_hb(i)=num_conti
14082       enddo
14083       do i=iturn4_start,iturn4_end
14084         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14085           .or. itype(i+3,1).eq.ntyp1 &
14086           .or. itype(i+4,1).eq.ntyp1) cycle
14087         dxi=dc(1,i)
14088         dyi=dc(2,i)
14089         dzi=dc(3,i)
14090         dx_normi=dc_norm(1,i)
14091         dy_normi=dc_norm(2,i)
14092         dz_normi=dc_norm(3,i)
14093         xmedi=c(1,i)+0.5d0*dxi
14094         ymedi=c(2,i)+0.5d0*dyi
14095         zmedi=c(3,i)+0.5d0*dzi
14096           xmedi=dmod(xmedi,boxxsize)
14097           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14098           ymedi=dmod(ymedi,boxysize)
14099           if (ymedi.lt.0) ymedi=ymedi+boxysize
14100           zmedi=dmod(zmedi,boxzsize)
14101           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14102         num_conti=num_cont_hb(i)
14103         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14104         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14105           call eturn4(i,eello_turn4)
14106         num_cont_hb(i)=num_conti
14107       enddo   ! i
14108 !
14109 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14110 !
14111       do i=iatel_s,iatel_e
14112         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14113         dxi=dc(1,i)
14114         dyi=dc(2,i)
14115         dzi=dc(3,i)
14116         dx_normi=dc_norm(1,i)
14117         dy_normi=dc_norm(2,i)
14118         dz_normi=dc_norm(3,i)
14119         xmedi=c(1,i)+0.5d0*dxi
14120         ymedi=c(2,i)+0.5d0*dyi
14121         zmedi=c(3,i)+0.5d0*dzi
14122           xmedi=dmod(xmedi,boxxsize)
14123           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14124           ymedi=dmod(ymedi,boxysize)
14125           if (ymedi.lt.0) ymedi=ymedi+boxysize
14126           zmedi=dmod(zmedi,boxzsize)
14127           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14128 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14129         num_conti=num_cont_hb(i)
14130         do j=ielstart(i),ielend(i)
14131           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14132           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14133         enddo ! j
14134         num_cont_hb(i)=num_conti
14135       enddo   ! i
14136 !      write (iout,*) "Number of loop steps in EELEC:",ind
14137 !d      do i=1,nres
14138 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14139 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14140 !d      enddo
14141 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14142 !cc      eel_loc=eel_loc+eello_turn3
14143 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14144       return
14145       end subroutine eelec_scale
14146 !-----------------------------------------------------------------------------
14147       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14148 !      implicit real*8 (a-h,o-z)
14149
14150       use comm_locel
14151 !      include 'DIMENSIONS'
14152 #ifdef MPI
14153       include "mpif.h"
14154 #endif
14155 !      include 'COMMON.CONTROL'
14156 !      include 'COMMON.IOUNITS'
14157 !      include 'COMMON.GEO'
14158 !      include 'COMMON.VAR'
14159 !      include 'COMMON.LOCAL'
14160 !      include 'COMMON.CHAIN'
14161 !      include 'COMMON.DERIV'
14162 !      include 'COMMON.INTERACT'
14163 !      include 'COMMON.CONTACTS'
14164 !      include 'COMMON.TORSION'
14165 !      include 'COMMON.VECTORS'
14166 !      include 'COMMON.FFIELD'
14167 !      include 'COMMON.TIME1'
14168       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14169       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14170       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14171 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14172       real(kind=8),dimension(4) :: muij
14173       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14174                     dist_temp, dist_init,sss_grad
14175       integer xshift,yshift,zshift
14176
14177 !el      integer :: num_conti,j1,j2
14178 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14179 !el                   dz_normi,xmedi,ymedi,zmedi
14180 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14181 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14182 !el          num_conti,j1,j2
14183 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14184 #ifdef MOMENT
14185       real(kind=8) :: scal_el=1.0d0
14186 #else
14187       real(kind=8) :: scal_el=0.5d0
14188 #endif
14189 ! 12/13/98
14190 ! 13-go grudnia roku pamietnego...
14191       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14192                                              0.0d0,1.0d0,0.0d0,&
14193                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14194 !el local variables
14195       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14196       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14197       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14198       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14199       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14200       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14201       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14202                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14203                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14204                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14205                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14206                   ecosam,ecosbm,ecosgm,ghalf,time00
14207 !      integer :: maxconts
14208 !      maxconts = nres/4
14209 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14210 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14211 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14212 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14213 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14214 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14215 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14216 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14217 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14218 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14219 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14220 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14221 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14222
14223 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14224 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14225
14226 #ifdef MPI
14227           time00=MPI_Wtime()
14228 #endif
14229 !d      write (iout,*) "eelecij",i,j
14230 !el          ind=ind+1
14231           iteli=itel(i)
14232           itelj=itel(j)
14233           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14234           aaa=app(iteli,itelj)
14235           bbb=bpp(iteli,itelj)
14236           ael6i=ael6(iteli,itelj)
14237           ael3i=ael3(iteli,itelj)
14238           dxj=dc(1,j)
14239           dyj=dc(2,j)
14240           dzj=dc(3,j)
14241           dx_normj=dc_norm(1,j)
14242           dy_normj=dc_norm(2,j)
14243           dz_normj=dc_norm(3,j)
14244 !          xj=c(1,j)+0.5D0*dxj-xmedi
14245 !          yj=c(2,j)+0.5D0*dyj-ymedi
14246 !          zj=c(3,j)+0.5D0*dzj-zmedi
14247           xj=c(1,j)+0.5D0*dxj
14248           yj=c(2,j)+0.5D0*dyj
14249           zj=c(3,j)+0.5D0*dzj
14250           xj=mod(xj,boxxsize)
14251           if (xj.lt.0) xj=xj+boxxsize
14252           yj=mod(yj,boxysize)
14253           if (yj.lt.0) yj=yj+boxysize
14254           zj=mod(zj,boxzsize)
14255           if (zj.lt.0) zj=zj+boxzsize
14256       isubchap=0
14257       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14258       xj_safe=xj
14259       yj_safe=yj
14260       zj_safe=zj
14261       do xshift=-1,1
14262       do yshift=-1,1
14263       do zshift=-1,1
14264           xj=xj_safe+xshift*boxxsize
14265           yj=yj_safe+yshift*boxysize
14266           zj=zj_safe+zshift*boxzsize
14267           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14268           if(dist_temp.lt.dist_init) then
14269             dist_init=dist_temp
14270             xj_temp=xj
14271             yj_temp=yj
14272             zj_temp=zj
14273             isubchap=1
14274           endif
14275        enddo
14276        enddo
14277        enddo
14278        if (isubchap.eq.1) then
14279 !C          print *,i,j
14280           xj=xj_temp-xmedi
14281           yj=yj_temp-ymedi
14282           zj=zj_temp-zmedi
14283        else
14284           xj=xj_safe-xmedi
14285           yj=yj_safe-ymedi
14286           zj=zj_safe-zmedi
14287        endif
14288
14289           rij=xj*xj+yj*yj+zj*zj
14290           rrmij=1.0D0/rij
14291           rij=dsqrt(rij)
14292           rmij=1.0D0/rij
14293 ! For extracting the short-range part of Evdwpp
14294           sss=sscale(rij/rpp(iteli,itelj))
14295             sss_ele_cut=sscale_ele(rij)
14296             sss_ele_grad=sscagrad_ele(rij)
14297             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14298 !             sss_ele_cut=1.0d0
14299 !             sss_ele_grad=0.0d0
14300             if (sss_ele_cut.le.0.0) go to 128
14301
14302           r3ij=rrmij*rmij
14303           r6ij=r3ij*r3ij
14304           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14305           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14306           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14307           fac=cosa-3.0D0*cosb*cosg
14308           ev1=aaa*r6ij*r6ij
14309 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14310           if (j.eq.i+2) ev1=scal_el*ev1
14311           ev2=bbb*r6ij
14312           fac3=ael6i*r6ij
14313           fac4=ael3i*r3ij
14314           evdwij=ev1+ev2
14315           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14316           el2=fac4*fac
14317           eesij=el1+el2
14318 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14319           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14320           ees=ees+eesij*sss_ele_cut
14321           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14322 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14323 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14324 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14325 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14326
14327           if (energy_dec) then
14328               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14329               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14330           endif
14331
14332 !
14333 ! Calculate contributions to the Cartesian gradient.
14334 !
14335 #ifdef SPLITELE
14336           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14337           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14338           fac1=fac
14339           erij(1)=xj*rmij
14340           erij(2)=yj*rmij
14341           erij(3)=zj*rmij
14342 !
14343 ! Radial derivatives. First process both termini of the fragment (i,j)
14344 !
14345           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14346           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14347           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14348 !          do k=1,3
14349 !            ghalf=0.5D0*ggg(k)
14350 !            gelc(k,i)=gelc(k,i)+ghalf
14351 !            gelc(k,j)=gelc(k,j)+ghalf
14352 !          enddo
14353 ! 9/28/08 AL Gradient compotents will be summed only at the end
14354           do k=1,3
14355             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14356             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14357           enddo
14358 !
14359 ! Loop over residues i+1 thru j-1.
14360 !
14361 !grad          do k=i+1,j-1
14362 !grad            do l=1,3
14363 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14364 !grad            enddo
14365 !grad          enddo
14366           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14367           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14368           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14369           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14370           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14371           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14372 !          do k=1,3
14373 !            ghalf=0.5D0*ggg(k)
14374 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14375 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14376 !          enddo
14377 ! 9/28/08 AL Gradient compotents will be summed only at the end
14378           do k=1,3
14379             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14380             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14381           enddo
14382 !
14383 ! Loop over residues i+1 thru j-1.
14384 !
14385 !grad          do k=i+1,j-1
14386 !grad            do l=1,3
14387 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14388 !grad            enddo
14389 !grad          enddo
14390 #else
14391           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14392           facel=(el1+eesij)*sss_ele_cut
14393           fac1=fac
14394           fac=-3*rrmij*(facvdw+facvdw+facel)
14395           erij(1)=xj*rmij
14396           erij(2)=yj*rmij
14397           erij(3)=zj*rmij
14398 !
14399 ! Radial derivatives. First process both termini of the fragment (i,j)
14400 !
14401           ggg(1)=fac*xj
14402           ggg(2)=fac*yj
14403           ggg(3)=fac*zj
14404 !          do k=1,3
14405 !            ghalf=0.5D0*ggg(k)
14406 !            gelc(k,i)=gelc(k,i)+ghalf
14407 !            gelc(k,j)=gelc(k,j)+ghalf
14408 !          enddo
14409 ! 9/28/08 AL Gradient compotents will be summed only at the end
14410           do k=1,3
14411             gelc_long(k,j)=gelc(k,j)+ggg(k)
14412             gelc_long(k,i)=gelc(k,i)-ggg(k)
14413           enddo
14414 !
14415 ! Loop over residues i+1 thru j-1.
14416 !
14417 !grad          do k=i+1,j-1
14418 !grad            do l=1,3
14419 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14420 !grad            enddo
14421 !grad          enddo
14422 ! 9/28/08 AL Gradient compotents will be summed only at the end
14423           ggg(1)=facvdw*xj
14424           ggg(2)=facvdw*yj
14425           ggg(3)=facvdw*zj
14426           do k=1,3
14427             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14428             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14429           enddo
14430 #endif
14431 !
14432 ! Angular part
14433 !
14434           ecosa=2.0D0*fac3*fac1+fac4
14435           fac4=-3.0D0*fac4
14436           fac3=-6.0D0*fac3
14437           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14438           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14439           do k=1,3
14440             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14441             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14442           enddo
14443 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14444 !d   &          (dcosg(k),k=1,3)
14445           do k=1,3
14446             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14447           enddo
14448 !          do k=1,3
14449 !            ghalf=0.5D0*ggg(k)
14450 !            gelc(k,i)=gelc(k,i)+ghalf
14451 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14452 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14453 !            gelc(k,j)=gelc(k,j)+ghalf
14454 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14455 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14456 !          enddo
14457 !grad          do k=i+1,j-1
14458 !grad            do l=1,3
14459 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14460 !grad            enddo
14461 !grad          enddo
14462           do k=1,3
14463             gelc(k,i)=gelc(k,i) &
14464                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14465                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14466                      *sss_ele_cut
14467             gelc(k,j)=gelc(k,j) &
14468                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14469                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14470                      *sss_ele_cut
14471             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14472             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14473           enddo
14474           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14475               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14476               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14477 !
14478 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14479 !   energy of a peptide unit is assumed in the form of a second-order
14480 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14481 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14482 !   are computed for EVERY pair of non-contiguous peptide groups.
14483 !
14484           if (j.lt.nres-1) then
14485             j1=j+1
14486             j2=j-1
14487           else
14488             j1=j-1
14489             j2=j-2
14490           endif
14491           kkk=0
14492           do k=1,2
14493             do l=1,2
14494               kkk=kkk+1
14495               muij(kkk)=mu(k,i)*mu(l,j)
14496             enddo
14497           enddo
14498 !d         write (iout,*) 'EELEC: i',i,' j',j
14499 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14500 !d          write(iout,*) 'muij',muij
14501           ury=scalar(uy(1,i),erij)
14502           urz=scalar(uz(1,i),erij)
14503           vry=scalar(uy(1,j),erij)
14504           vrz=scalar(uz(1,j),erij)
14505           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14506           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14507           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14508           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14509           fac=dsqrt(-ael6i)*r3ij
14510           a22=a22*fac
14511           a23=a23*fac
14512           a32=a32*fac
14513           a33=a33*fac
14514 !d          write (iout,'(4i5,4f10.5)')
14515 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14516 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14517 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14518 !d     &      uy(:,j),uz(:,j)
14519 !d          write (iout,'(4f10.5)')
14520 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14521 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14522 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14523 !d           write (iout,'(9f10.5/)')
14524 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14525 ! Derivatives of the elements of A in virtual-bond vectors
14526           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14527           do k=1,3
14528             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14529             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14530             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14531             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14532             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14533             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14534             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14535             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14536             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14537             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14538             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14539             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14540           enddo
14541 ! Compute radial contributions to the gradient
14542           facr=-3.0d0*rrmij
14543           a22der=a22*facr
14544           a23der=a23*facr
14545           a32der=a32*facr
14546           a33der=a33*facr
14547           agg(1,1)=a22der*xj
14548           agg(2,1)=a22der*yj
14549           agg(3,1)=a22der*zj
14550           agg(1,2)=a23der*xj
14551           agg(2,2)=a23der*yj
14552           agg(3,2)=a23der*zj
14553           agg(1,3)=a32der*xj
14554           agg(2,3)=a32der*yj
14555           agg(3,3)=a32der*zj
14556           agg(1,4)=a33der*xj
14557           agg(2,4)=a33der*yj
14558           agg(3,4)=a33der*zj
14559 ! Add the contributions coming from er
14560           fac3=-3.0d0*fac
14561           do k=1,3
14562             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14563             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14564             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14565             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14566           enddo
14567           do k=1,3
14568 ! Derivatives in DC(i)
14569 !grad            ghalf1=0.5d0*agg(k,1)
14570 !grad            ghalf2=0.5d0*agg(k,2)
14571 !grad            ghalf3=0.5d0*agg(k,3)
14572 !grad            ghalf4=0.5d0*agg(k,4)
14573             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14574             -3.0d0*uryg(k,2)*vry)!+ghalf1
14575             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14576             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14577             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14578             -3.0d0*urzg(k,2)*vry)!+ghalf3
14579             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14580             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14581 ! Derivatives in DC(i+1)
14582             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14583             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14584             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14585             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14586             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14587             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14588             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14589             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14590 ! Derivatives in DC(j)
14591             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14592             -3.0d0*vryg(k,2)*ury)!+ghalf1
14593             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14594             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14595             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14596             -3.0d0*vryg(k,2)*urz)!+ghalf3
14597             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14598             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14599 ! Derivatives in DC(j+1) or DC(nres-1)
14600             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14601             -3.0d0*vryg(k,3)*ury)
14602             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14603             -3.0d0*vrzg(k,3)*ury)
14604             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14605             -3.0d0*vryg(k,3)*urz)
14606             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14607             -3.0d0*vrzg(k,3)*urz)
14608 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14609 !grad              do l=1,4
14610 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14611 !grad              enddo
14612 !grad            endif
14613           enddo
14614           acipa(1,1)=a22
14615           acipa(1,2)=a23
14616           acipa(2,1)=a32
14617           acipa(2,2)=a33
14618           a22=-a22
14619           a23=-a23
14620           do l=1,2
14621             do k=1,3
14622               agg(k,l)=-agg(k,l)
14623               aggi(k,l)=-aggi(k,l)
14624               aggi1(k,l)=-aggi1(k,l)
14625               aggj(k,l)=-aggj(k,l)
14626               aggj1(k,l)=-aggj1(k,l)
14627             enddo
14628           enddo
14629           if (j.lt.nres-1) then
14630             a22=-a22
14631             a32=-a32
14632             do l=1,3,2
14633               do k=1,3
14634                 agg(k,l)=-agg(k,l)
14635                 aggi(k,l)=-aggi(k,l)
14636                 aggi1(k,l)=-aggi1(k,l)
14637                 aggj(k,l)=-aggj(k,l)
14638                 aggj1(k,l)=-aggj1(k,l)
14639               enddo
14640             enddo
14641           else
14642             a22=-a22
14643             a23=-a23
14644             a32=-a32
14645             a33=-a33
14646             do l=1,4
14647               do k=1,3
14648                 agg(k,l)=-agg(k,l)
14649                 aggi(k,l)=-aggi(k,l)
14650                 aggi1(k,l)=-aggi1(k,l)
14651                 aggj(k,l)=-aggj(k,l)
14652                 aggj1(k,l)=-aggj1(k,l)
14653               enddo
14654             enddo
14655           endif
14656           ENDIF ! WCORR
14657           IF (wel_loc.gt.0.0d0) THEN
14658 ! Contribution to the local-electrostatic energy coming from the i-j pair
14659           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14660            +a33*muij(4)
14661 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14662
14663           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14664                   'eelloc',i,j,eel_loc_ij
14665 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14666
14667           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14668 ! Partial derivatives in virtual-bond dihedral angles gamma
14669           if (i.gt.1) &
14670           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14671                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14672                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14673                  *sss_ele_cut
14674           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14675                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14676                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14677                  *sss_ele_cut
14678            xtemp(1)=xj
14679            xtemp(2)=yj
14680            xtemp(3)=zj
14681
14682 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14683           do l=1,3
14684             ggg(l)=(agg(l,1)*muij(1)+ &
14685                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14686             *sss_ele_cut &
14687              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14688
14689             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14690             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14691 !grad            ghalf=0.5d0*ggg(l)
14692 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14693 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14694           enddo
14695 !grad          do k=i+1,j2
14696 !grad            do l=1,3
14697 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14698 !grad            enddo
14699 !grad          enddo
14700 ! Remaining derivatives of eello
14701           do l=1,3
14702             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14703                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14704             *sss_ele_cut
14705
14706             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14707                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14708             *sss_ele_cut
14709
14710             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14711                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14712             *sss_ele_cut
14713
14714             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14715                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14716             *sss_ele_cut
14717
14718           enddo
14719           ENDIF
14720 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14721 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14722           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14723              .and. num_conti.le.maxconts) then
14724 !            write (iout,*) i,j," entered corr"
14725 !
14726 ! Calculate the contact function. The ith column of the array JCONT will
14727 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14728 ! greater than I). The arrays FACONT and GACONT will contain the values of
14729 ! the contact function and its derivative.
14730 !           r0ij=1.02D0*rpp(iteli,itelj)
14731 !           r0ij=1.11D0*rpp(iteli,itelj)
14732             r0ij=2.20D0*rpp(iteli,itelj)
14733 !           r0ij=1.55D0*rpp(iteli,itelj)
14734             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14735 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14736             if (fcont.gt.0.0D0) then
14737               num_conti=num_conti+1
14738               if (num_conti.gt.maxconts) then
14739 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14740                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14741                                ' will skip next contacts for this conf.',num_conti
14742               else
14743                 jcont_hb(num_conti,i)=j
14744 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14745 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14746                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14747                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14748 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14749 !  terms.
14750                 d_cont(num_conti,i)=rij
14751 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14752 !     --- Electrostatic-interaction matrix ---
14753                 a_chuj(1,1,num_conti,i)=a22
14754                 a_chuj(1,2,num_conti,i)=a23
14755                 a_chuj(2,1,num_conti,i)=a32
14756                 a_chuj(2,2,num_conti,i)=a33
14757 !     --- Gradient of rij
14758                 do kkk=1,3
14759                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14760                 enddo
14761                 kkll=0
14762                 do k=1,2
14763                   do l=1,2
14764                     kkll=kkll+1
14765                     do m=1,3
14766                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14767                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14768                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14769                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14770                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14771                     enddo
14772                   enddo
14773                 enddo
14774                 ENDIF
14775                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14776 ! Calculate contact energies
14777                 cosa4=4.0D0*cosa
14778                 wij=cosa-3.0D0*cosb*cosg
14779                 cosbg1=cosb+cosg
14780                 cosbg2=cosb-cosg
14781 !               fac3=dsqrt(-ael6i)/r0ij**3
14782                 fac3=dsqrt(-ael6i)*r3ij
14783 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14784                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14785                 if (ees0tmp.gt.0) then
14786                   ees0pij=dsqrt(ees0tmp)
14787                 else
14788                   ees0pij=0
14789                 endif
14790 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14791                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14792                 if (ees0tmp.gt.0) then
14793                   ees0mij=dsqrt(ees0tmp)
14794                 else
14795                   ees0mij=0
14796                 endif
14797 !               ees0mij=0.0D0
14798                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14799                      *sss_ele_cut
14800
14801                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14802                      *sss_ele_cut
14803
14804 ! Diagnostics. Comment out or remove after debugging!
14805 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14806 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14807 !               ees0m(num_conti,i)=0.0D0
14808 ! End diagnostics.
14809 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14810 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14811 ! Angular derivatives of the contact function
14812                 ees0pij1=fac3/ees0pij
14813                 ees0mij1=fac3/ees0mij
14814                 fac3p=-3.0D0*fac3*rrmij
14815                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14816                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14817 !               ees0mij1=0.0D0
14818                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14819                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14820                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14821                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14822                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14823                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14824                 ecosap=ecosa1+ecosa2
14825                 ecosbp=ecosb1+ecosb2
14826                 ecosgp=ecosg1+ecosg2
14827                 ecosam=ecosa1-ecosa2
14828                 ecosbm=ecosb1-ecosb2
14829                 ecosgm=ecosg1-ecosg2
14830 ! Diagnostics
14831 !               ecosap=ecosa1
14832 !               ecosbp=ecosb1
14833 !               ecosgp=ecosg1
14834 !               ecosam=0.0D0
14835 !               ecosbm=0.0D0
14836 !               ecosgm=0.0D0
14837 ! End diagnostics
14838                 facont_hb(num_conti,i)=fcont
14839                 fprimcont=fprimcont/rij
14840 !d              facont_hb(num_conti,i)=1.0D0
14841 ! Following line is for diagnostics.
14842 !d              fprimcont=0.0D0
14843                 do k=1,3
14844                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14845                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14846                 enddo
14847                 do k=1,3
14848                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14849                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14850                 enddo
14851 !                gggp(1)=gggp(1)+ees0pijp*xj
14852 !                gggp(2)=gggp(2)+ees0pijp*yj
14853 !                gggp(3)=gggp(3)+ees0pijp*zj
14854 !                gggm(1)=gggm(1)+ees0mijp*xj
14855 !                gggm(2)=gggm(2)+ees0mijp*yj
14856 !                gggm(3)=gggm(3)+ees0mijp*zj
14857                 gggp(1)=gggp(1)+ees0pijp*xj &
14858                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14859                 gggp(2)=gggp(2)+ees0pijp*yj &
14860                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14861                 gggp(3)=gggp(3)+ees0pijp*zj &
14862                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14863
14864                 gggm(1)=gggm(1)+ees0mijp*xj &
14865                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14866
14867                 gggm(2)=gggm(2)+ees0mijp*yj &
14868                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14869
14870                 gggm(3)=gggm(3)+ees0mijp*zj &
14871                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14872
14873 ! Derivatives due to the contact function
14874                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14875                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14876                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14877                 do k=1,3
14878 !
14879 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14880 !          following the change of gradient-summation algorithm.
14881 !
14882 !grad                  ghalfp=0.5D0*gggp(k)
14883 !grad                  ghalfm=0.5D0*gggm(k)
14884 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14885 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14886 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14887 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14888 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14889 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14890 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14891 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14892 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14893 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14894 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14895 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14896 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14897 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14898                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14899                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14900                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14901                      *sss_ele_cut
14902
14903                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14904                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14905                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14906                      *sss_ele_cut
14907
14908                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14909                      *sss_ele_cut
14910
14911                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14912                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14913                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14914                      *sss_ele_cut
14915
14916                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14917                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14918                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14919                      *sss_ele_cut
14920
14921                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14922                      *sss_ele_cut
14923
14924                 enddo
14925               ENDIF ! wcorr
14926               endif  ! num_conti.le.maxconts
14927             endif  ! fcont.gt.0
14928           endif    ! j.gt.i+1
14929           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14930             do k=1,4
14931               do l=1,3
14932                 ghalf=0.5d0*agg(l,k)
14933                 aggi(l,k)=aggi(l,k)+ghalf
14934                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14935                 aggj(l,k)=aggj(l,k)+ghalf
14936               enddo
14937             enddo
14938             if (j.eq.nres-1 .and. i.lt.j-2) then
14939               do k=1,4
14940                 do l=1,3
14941                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14942                 enddo
14943               enddo
14944             endif
14945           endif
14946  128      continue
14947 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14948       return
14949       end subroutine eelecij_scale
14950 !-----------------------------------------------------------------------------
14951       subroutine evdwpp_short(evdw1)
14952 !
14953 ! Compute Evdwpp
14954 !
14955 !      implicit real*8 (a-h,o-z)
14956 !      include 'DIMENSIONS'
14957 !      include 'COMMON.CONTROL'
14958 !      include 'COMMON.IOUNITS'
14959 !      include 'COMMON.GEO'
14960 !      include 'COMMON.VAR'
14961 !      include 'COMMON.LOCAL'
14962 !      include 'COMMON.CHAIN'
14963 !      include 'COMMON.DERIV'
14964 !      include 'COMMON.INTERACT'
14965 !      include 'COMMON.CONTACTS'
14966 !      include 'COMMON.TORSION'
14967 !      include 'COMMON.VECTORS'
14968 !      include 'COMMON.FFIELD'
14969       real(kind=8),dimension(3) :: ggg
14970 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14971 #ifdef MOMENT
14972       real(kind=8) :: scal_el=1.0d0
14973 #else
14974       real(kind=8) :: scal_el=0.5d0
14975 #endif
14976 !el local variables
14977       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14978       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14979       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14980                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14981                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14982       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14983                     dist_temp, dist_init,sss_grad
14984       integer xshift,yshift,zshift
14985
14986
14987       evdw1=0.0D0
14988 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14989 !     & " iatel_e_vdw",iatel_e_vdw
14990       call flush(iout)
14991       do i=iatel_s_vdw,iatel_e_vdw
14992         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14993         dxi=dc(1,i)
14994         dyi=dc(2,i)
14995         dzi=dc(3,i)
14996         dx_normi=dc_norm(1,i)
14997         dy_normi=dc_norm(2,i)
14998         dz_normi=dc_norm(3,i)
14999         xmedi=c(1,i)+0.5d0*dxi
15000         ymedi=c(2,i)+0.5d0*dyi
15001         zmedi=c(3,i)+0.5d0*dzi
15002           xmedi=dmod(xmedi,boxxsize)
15003           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15004           ymedi=dmod(ymedi,boxysize)
15005           if (ymedi.lt.0) ymedi=ymedi+boxysize
15006           zmedi=dmod(zmedi,boxzsize)
15007           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15008         num_conti=0
15009 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15010 !     &   ' ielend',ielend_vdw(i)
15011         call flush(iout)
15012         do j=ielstart_vdw(i),ielend_vdw(i)
15013           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15014 !el          ind=ind+1
15015           iteli=itel(i)
15016           itelj=itel(j)
15017           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15018           aaa=app(iteli,itelj)
15019           bbb=bpp(iteli,itelj)
15020           dxj=dc(1,j)
15021           dyj=dc(2,j)
15022           dzj=dc(3,j)
15023           dx_normj=dc_norm(1,j)
15024           dy_normj=dc_norm(2,j)
15025           dz_normj=dc_norm(3,j)
15026 !          xj=c(1,j)+0.5D0*dxj-xmedi
15027 !          yj=c(2,j)+0.5D0*dyj-ymedi
15028 !          zj=c(3,j)+0.5D0*dzj-zmedi
15029           xj=c(1,j)+0.5D0*dxj
15030           yj=c(2,j)+0.5D0*dyj
15031           zj=c(3,j)+0.5D0*dzj
15032           xj=mod(xj,boxxsize)
15033           if (xj.lt.0) xj=xj+boxxsize
15034           yj=mod(yj,boxysize)
15035           if (yj.lt.0) yj=yj+boxysize
15036           zj=mod(zj,boxzsize)
15037           if (zj.lt.0) zj=zj+boxzsize
15038       isubchap=0
15039       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15040       xj_safe=xj
15041       yj_safe=yj
15042       zj_safe=zj
15043       do xshift=-1,1
15044       do yshift=-1,1
15045       do zshift=-1,1
15046           xj=xj_safe+xshift*boxxsize
15047           yj=yj_safe+yshift*boxysize
15048           zj=zj_safe+zshift*boxzsize
15049           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15050           if(dist_temp.lt.dist_init) then
15051             dist_init=dist_temp
15052             xj_temp=xj
15053             yj_temp=yj
15054             zj_temp=zj
15055             isubchap=1
15056           endif
15057        enddo
15058        enddo
15059        enddo
15060        if (isubchap.eq.1) then
15061 !C          print *,i,j
15062           xj=xj_temp-xmedi
15063           yj=yj_temp-ymedi
15064           zj=zj_temp-zmedi
15065        else
15066           xj=xj_safe-xmedi
15067           yj=yj_safe-ymedi
15068           zj=zj_safe-zmedi
15069        endif
15070
15071           rij=xj*xj+yj*yj+zj*zj
15072           rrmij=1.0D0/rij
15073           rij=dsqrt(rij)
15074           sss=sscale(rij/rpp(iteli,itelj))
15075             sss_ele_cut=sscale_ele(rij)
15076             sss_ele_grad=sscagrad_ele(rij)
15077             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15078             if (sss_ele_cut.le.0.0) cycle
15079           if (sss.gt.0.0d0) then
15080             rmij=1.0D0/rij
15081             r3ij=rrmij*rmij
15082             r6ij=r3ij*r3ij
15083             ev1=aaa*r6ij*r6ij
15084 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15085             if (j.eq.i+2) ev1=scal_el*ev1
15086             ev2=bbb*r6ij
15087             evdwij=ev1+ev2
15088             if (energy_dec) then
15089               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15090             endif
15091             evdw1=evdw1+evdwij*sss*sss_ele_cut
15092 !
15093 ! Calculate contributions to the Cartesian gradient.
15094 !
15095             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15096 !            ggg(1)=facvdw*xj
15097 !            ggg(2)=facvdw*yj
15098 !            ggg(3)=facvdw*zj
15099           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15100           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15101           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15102           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15103           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15104           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15105
15106             do k=1,3
15107               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15108               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15109             enddo
15110           endif
15111         enddo ! j
15112       enddo   ! i
15113       return
15114       end subroutine evdwpp_short
15115 !-----------------------------------------------------------------------------
15116       subroutine escp_long(evdw2,evdw2_14)
15117 !
15118 ! This subroutine calculates the excluded-volume interaction energy between
15119 ! peptide-group centers and side chains and its gradient in virtual-bond and
15120 ! side-chain vectors.
15121 !
15122 !      implicit real*8 (a-h,o-z)
15123 !      include 'DIMENSIONS'
15124 !      include 'COMMON.GEO'
15125 !      include 'COMMON.VAR'
15126 !      include 'COMMON.LOCAL'
15127 !      include 'COMMON.CHAIN'
15128 !      include 'COMMON.DERIV'
15129 !      include 'COMMON.INTERACT'
15130 !      include 'COMMON.FFIELD'
15131 !      include 'COMMON.IOUNITS'
15132 !      include 'COMMON.CONTROL'
15133       real(kind=8),dimension(3) :: ggg
15134 !el local variables
15135       integer :: i,iint,j,k,iteli,itypj,subchap
15136       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15137       real(kind=8) :: evdw2,evdw2_14,evdwij
15138       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15139                     dist_temp, dist_init
15140
15141       evdw2=0.0D0
15142       evdw2_14=0.0d0
15143 !d    print '(a)','Enter ESCP'
15144 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15145       do i=iatscp_s,iatscp_e
15146         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15147         iteli=itel(i)
15148         xi=0.5D0*(c(1,i)+c(1,i+1))
15149         yi=0.5D0*(c(2,i)+c(2,i+1))
15150         zi=0.5D0*(c(3,i)+c(3,i+1))
15151           xi=mod(xi,boxxsize)
15152           if (xi.lt.0) xi=xi+boxxsize
15153           yi=mod(yi,boxysize)
15154           if (yi.lt.0) yi=yi+boxysize
15155           zi=mod(zi,boxzsize)
15156           if (zi.lt.0) zi=zi+boxzsize
15157
15158         do iint=1,nscp_gr(i)
15159
15160         do j=iscpstart(i,iint),iscpend(i,iint)
15161           itypj=itype(j,1)
15162           if (itypj.eq.ntyp1) cycle
15163 ! Uncomment following three lines for SC-p interactions
15164 !         xj=c(1,nres+j)-xi
15165 !         yj=c(2,nres+j)-yi
15166 !         zj=c(3,nres+j)-zi
15167 ! Uncomment following three lines for Ca-p interactions
15168           xj=c(1,j)
15169           yj=c(2,j)
15170           zj=c(3,j)
15171           xj=mod(xj,boxxsize)
15172           if (xj.lt.0) xj=xj+boxxsize
15173           yj=mod(yj,boxysize)
15174           if (yj.lt.0) yj=yj+boxysize
15175           zj=mod(zj,boxzsize)
15176           if (zj.lt.0) zj=zj+boxzsize
15177       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15178       xj_safe=xj
15179       yj_safe=yj
15180       zj_safe=zj
15181       subchap=0
15182       do xshift=-1,1
15183       do yshift=-1,1
15184       do zshift=-1,1
15185           xj=xj_safe+xshift*boxxsize
15186           yj=yj_safe+yshift*boxysize
15187           zj=zj_safe+zshift*boxzsize
15188           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15189           if(dist_temp.lt.dist_init) then
15190             dist_init=dist_temp
15191             xj_temp=xj
15192             yj_temp=yj
15193             zj_temp=zj
15194             subchap=1
15195           endif
15196        enddo
15197        enddo
15198        enddo
15199        if (subchap.eq.1) then
15200           xj=xj_temp-xi
15201           yj=yj_temp-yi
15202           zj=zj_temp-zi
15203        else
15204           xj=xj_safe-xi
15205           yj=yj_safe-yi
15206           zj=zj_safe-zi
15207        endif
15208           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15209
15210           rij=dsqrt(1.0d0/rrij)
15211             sss_ele_cut=sscale_ele(rij)
15212             sss_ele_grad=sscagrad_ele(rij)
15213 !            print *,sss_ele_cut,sss_ele_grad,&
15214 !            (rij),r_cut_ele,rlamb_ele
15215             if (sss_ele_cut.le.0.0) cycle
15216           sss=sscale((rij/rscp(itypj,iteli)))
15217           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15218           if (sss.lt.1.0d0) then
15219
15220             fac=rrij**expon2
15221             e1=fac*fac*aad(itypj,iteli)
15222             e2=fac*bad(itypj,iteli)
15223             if (iabs(j-i) .le. 2) then
15224               e1=scal14*e1
15225               e2=scal14*e2
15226               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15227             endif
15228             evdwij=e1+e2
15229             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15230             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15231                 'evdw2',i,j,sss,evdwij
15232 !
15233 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15234 !
15235             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15236             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15237             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15238             ggg(1)=xj*fac
15239             ggg(2)=yj*fac
15240             ggg(3)=zj*fac
15241 ! Uncomment following three lines for SC-p interactions
15242 !           do k=1,3
15243 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15244 !           enddo
15245 ! Uncomment following line for SC-p interactions
15246 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15247             do k=1,3
15248               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15249               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15250             enddo
15251           endif
15252         enddo
15253
15254         enddo ! iint
15255       enddo ! i
15256       do i=1,nct
15257         do j=1,3
15258           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15259           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15260           gradx_scp(j,i)=expon*gradx_scp(j,i)
15261         enddo
15262       enddo
15263 !******************************************************************************
15264 !
15265 !                              N O T E !!!
15266 !
15267 ! To save time the factor EXPON has been extracted from ALL components
15268 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15269 ! use!
15270 !
15271 !******************************************************************************
15272       return
15273       end subroutine escp_long
15274 !-----------------------------------------------------------------------------
15275       subroutine escp_short(evdw2,evdw2_14)
15276 !
15277 ! This subroutine calculates the excluded-volume interaction energy between
15278 ! peptide-group centers and side chains and its gradient in virtual-bond and
15279 ! side-chain vectors.
15280 !
15281 !      implicit real*8 (a-h,o-z)
15282 !      include 'DIMENSIONS'
15283 !      include 'COMMON.GEO'
15284 !      include 'COMMON.VAR'
15285 !      include 'COMMON.LOCAL'
15286 !      include 'COMMON.CHAIN'
15287 !      include 'COMMON.DERIV'
15288 !      include 'COMMON.INTERACT'
15289 !      include 'COMMON.FFIELD'
15290 !      include 'COMMON.IOUNITS'
15291 !      include 'COMMON.CONTROL'
15292       real(kind=8),dimension(3) :: ggg
15293 !el local variables
15294       integer :: i,iint,j,k,iteli,itypj,subchap
15295       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15296       real(kind=8) :: evdw2,evdw2_14,evdwij
15297       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15298                     dist_temp, dist_init
15299
15300       evdw2=0.0D0
15301       evdw2_14=0.0d0
15302 !d    print '(a)','Enter ESCP'
15303 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15304       do i=iatscp_s,iatscp_e
15305         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15306         iteli=itel(i)
15307         xi=0.5D0*(c(1,i)+c(1,i+1))
15308         yi=0.5D0*(c(2,i)+c(2,i+1))
15309         zi=0.5D0*(c(3,i)+c(3,i+1))
15310           xi=mod(xi,boxxsize)
15311           if (xi.lt.0) xi=xi+boxxsize
15312           yi=mod(yi,boxysize)
15313           if (yi.lt.0) yi=yi+boxysize
15314           zi=mod(zi,boxzsize)
15315           if (zi.lt.0) zi=zi+boxzsize
15316
15317         do iint=1,nscp_gr(i)
15318
15319         do j=iscpstart(i,iint),iscpend(i,iint)
15320           itypj=itype(j,1)
15321           if (itypj.eq.ntyp1) cycle
15322 ! Uncomment following three lines for SC-p interactions
15323 !         xj=c(1,nres+j)-xi
15324 !         yj=c(2,nres+j)-yi
15325 !         zj=c(3,nres+j)-zi
15326 ! Uncomment following three lines for Ca-p interactions
15327 !          xj=c(1,j)-xi
15328 !          yj=c(2,j)-yi
15329 !          zj=c(3,j)-zi
15330           xj=c(1,j)
15331           yj=c(2,j)
15332           zj=c(3,j)
15333           xj=mod(xj,boxxsize)
15334           if (xj.lt.0) xj=xj+boxxsize
15335           yj=mod(yj,boxysize)
15336           if (yj.lt.0) yj=yj+boxysize
15337           zj=mod(zj,boxzsize)
15338           if (zj.lt.0) zj=zj+boxzsize
15339       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15340       xj_safe=xj
15341       yj_safe=yj
15342       zj_safe=zj
15343       subchap=0
15344       do xshift=-1,1
15345       do yshift=-1,1
15346       do zshift=-1,1
15347           xj=xj_safe+xshift*boxxsize
15348           yj=yj_safe+yshift*boxysize
15349           zj=zj_safe+zshift*boxzsize
15350           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15351           if(dist_temp.lt.dist_init) then
15352             dist_init=dist_temp
15353             xj_temp=xj
15354             yj_temp=yj
15355             zj_temp=zj
15356             subchap=1
15357           endif
15358        enddo
15359        enddo
15360        enddo
15361        if (subchap.eq.1) then
15362           xj=xj_temp-xi
15363           yj=yj_temp-yi
15364           zj=zj_temp-zi
15365        else
15366           xj=xj_safe-xi
15367           yj=yj_safe-yi
15368           zj=zj_safe-zi
15369        endif
15370
15371           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15372           rij=dsqrt(1.0d0/rrij)
15373             sss_ele_cut=sscale_ele(rij)
15374             sss_ele_grad=sscagrad_ele(rij)
15375 !            print *,sss_ele_cut,sss_ele_grad,&
15376 !            (rij),r_cut_ele,rlamb_ele
15377             if (sss_ele_cut.le.0.0) cycle
15378           sss=sscale(rij/rscp(itypj,iteli))
15379           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15380           if (sss.gt.0.0d0) then
15381
15382             fac=rrij**expon2
15383             e1=fac*fac*aad(itypj,iteli)
15384             e2=fac*bad(itypj,iteli)
15385             if (iabs(j-i) .le. 2) then
15386               e1=scal14*e1
15387               e2=scal14*e2
15388               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15389             endif
15390             evdwij=e1+e2
15391             evdw2=evdw2+evdwij*sss*sss_ele_cut
15392             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15393                 'evdw2',i,j,sss,evdwij
15394 !
15395 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15396 !
15397             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15398             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15399             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15400
15401             ggg(1)=xj*fac
15402             ggg(2)=yj*fac
15403             ggg(3)=zj*fac
15404 ! Uncomment following three lines for SC-p interactions
15405 !           do k=1,3
15406 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15407 !           enddo
15408 ! Uncomment following line for SC-p interactions
15409 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15410             do k=1,3
15411               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15412               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15413             enddo
15414           endif
15415         enddo
15416
15417         enddo ! iint
15418       enddo ! i
15419       do i=1,nct
15420         do j=1,3
15421           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15422           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15423           gradx_scp(j,i)=expon*gradx_scp(j,i)
15424         enddo
15425       enddo
15426 !******************************************************************************
15427 !
15428 !                              N O T E !!!
15429 !
15430 ! To save time the factor EXPON has been extracted from ALL components
15431 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15432 ! use!
15433 !
15434 !******************************************************************************
15435       return
15436       end subroutine escp_short
15437 !-----------------------------------------------------------------------------
15438 ! energy_p_new-sep_barrier.F
15439 !-----------------------------------------------------------------------------
15440       subroutine sc_grad_scale(scalfac)
15441 !      implicit real*8 (a-h,o-z)
15442       use calc_data
15443 !      include 'DIMENSIONS'
15444 !      include 'COMMON.CHAIN'
15445 !      include 'COMMON.DERIV'
15446 !      include 'COMMON.CALC'
15447 !      include 'COMMON.IOUNITS'
15448       real(kind=8),dimension(3) :: dcosom1,dcosom2
15449       real(kind=8) :: scalfac
15450 !el local variables
15451 !      integer :: i,j,k,l
15452
15453       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15454       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15455       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15456            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15457 ! diagnostics only
15458 !      eom1=0.0d0
15459 !      eom2=0.0d0
15460 !      eom12=evdwij*eps1_om12
15461 ! end diagnostics
15462 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15463 !     &  " sigder",sigder
15464 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15465 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15466       do k=1,3
15467         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15468         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15469       enddo
15470       do k=1,3
15471         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15472          *sss_ele_cut
15473       enddo
15474 !      write (iout,*) "gg",(gg(k),k=1,3)
15475       do k=1,3
15476         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15477                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15478                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15479                  *sss_ele_cut
15480         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15481                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15482                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15483          *sss_ele_cut
15484 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15485 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15486 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15487 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15488       enddo
15489 !
15490 ! Calculate the components of the gradient in DC and X
15491 !
15492       do l=1,3
15493         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15494         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15495       enddo
15496       return
15497       end subroutine sc_grad_scale
15498 !-----------------------------------------------------------------------------
15499 ! energy_split-sep.F
15500 !-----------------------------------------------------------------------------
15501       subroutine etotal_long(energia)
15502 !
15503 ! Compute the long-range slow-varying contributions to the energy
15504 !
15505 !      implicit real*8 (a-h,o-z)
15506 !      include 'DIMENSIONS'
15507       use MD_data, only: totT,usampl,eq_time
15508 #ifndef ISNAN
15509       external proc_proc
15510 #ifdef WINPGI
15511 !MS$ATTRIBUTES C ::  proc_proc
15512 #endif
15513 #endif
15514 #ifdef MPI
15515       include "mpif.h"
15516       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15517 #endif
15518 !      include 'COMMON.SETUP'
15519 !      include 'COMMON.IOUNITS'
15520 !      include 'COMMON.FFIELD'
15521 !      include 'COMMON.DERIV'
15522 !      include 'COMMON.INTERACT'
15523 !      include 'COMMON.SBRIDGE'
15524 !      include 'COMMON.CHAIN'
15525 !      include 'COMMON.VAR'
15526 !      include 'COMMON.LOCAL'
15527 !      include 'COMMON.MD'
15528       real(kind=8),dimension(0:n_ene) :: energia
15529 !el local variables
15530       integer :: i,n_corr,n_corr1,ierror,ierr
15531       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15532                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15533                   ecorr,ecorr5,ecorr6,eturn6,time00
15534 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15535 !elwrite(iout,*)"in etotal long"
15536
15537       if (modecalc.eq.12.or.modecalc.eq.14) then
15538 #ifdef MPI
15539 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15540 #else
15541         call int_from_cart1(.false.)
15542 #endif
15543       endif
15544 !elwrite(iout,*)"in etotal long"
15545
15546 #ifdef MPI
15547 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15548 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15549       call flush(iout)
15550       if (nfgtasks.gt.1) then
15551         time00=MPI_Wtime()
15552 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15553         if (fg_rank.eq.0) then
15554           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15555 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15556 !          call flush(iout)
15557 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15558 ! FG slaves as WEIGHTS array.
15559           weights_(1)=wsc
15560           weights_(2)=wscp
15561           weights_(3)=welec
15562           weights_(4)=wcorr
15563           weights_(5)=wcorr5
15564           weights_(6)=wcorr6
15565           weights_(7)=wel_loc
15566           weights_(8)=wturn3
15567           weights_(9)=wturn4
15568           weights_(10)=wturn6
15569           weights_(11)=wang
15570           weights_(12)=wscloc
15571           weights_(13)=wtor
15572           weights_(14)=wtor_d
15573           weights_(15)=wstrain
15574           weights_(16)=wvdwpp
15575           weights_(17)=wbond
15576           weights_(18)=scal14
15577           weights_(21)=wsccor
15578 ! FG Master broadcasts the WEIGHTS_ array
15579           call MPI_Bcast(weights_(1),n_ene,&
15580               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15581         else
15582 ! FG slaves receive the WEIGHTS array
15583           call MPI_Bcast(weights(1),n_ene,&
15584               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15585           wsc=weights(1)
15586           wscp=weights(2)
15587           welec=weights(3)
15588           wcorr=weights(4)
15589           wcorr5=weights(5)
15590           wcorr6=weights(6)
15591           wel_loc=weights(7)
15592           wturn3=weights(8)
15593           wturn4=weights(9)
15594           wturn6=weights(10)
15595           wang=weights(11)
15596           wscloc=weights(12)
15597           wtor=weights(13)
15598           wtor_d=weights(14)
15599           wstrain=weights(15)
15600           wvdwpp=weights(16)
15601           wbond=weights(17)
15602           scal14=weights(18)
15603           wsccor=weights(21)
15604         endif
15605         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15606           king,FG_COMM,IERR)
15607          time_Bcast=time_Bcast+MPI_Wtime()-time00
15608          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15609 !        call chainbuild_cart
15610 !        call int_from_cart1(.false.)
15611       endif
15612 !      write (iout,*) 'Processor',myrank,
15613 !     &  ' calling etotal_short ipot=',ipot
15614 !      call flush(iout)
15615 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15616 #endif
15617 !d    print *,'nnt=',nnt,' nct=',nct
15618 !
15619 !elwrite(iout,*)"in etotal long"
15620 ! Compute the side-chain and electrostatic interaction energy
15621 !
15622       goto (101,102,103,104,105,106) ipot
15623 ! Lennard-Jones potential.
15624   101 call elj_long(evdw)
15625 !d    print '(a)','Exit ELJ'
15626       goto 107
15627 ! Lennard-Jones-Kihara potential (shifted).
15628   102 call eljk_long(evdw)
15629       goto 107
15630 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15631   103 call ebp_long(evdw)
15632       goto 107
15633 ! Gay-Berne potential (shifted LJ, angular dependence).
15634   104 call egb_long(evdw)
15635       goto 107
15636 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15637   105 call egbv_long(evdw)
15638       goto 107
15639 ! Soft-sphere potential
15640   106 call e_softsphere(evdw)
15641 !
15642 ! Calculate electrostatic (H-bonding) energy of the main chain.
15643 !
15644   107 continue
15645       call vec_and_deriv
15646       if (ipot.lt.6) then
15647 #ifdef SPLITELE
15648          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15649              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15650              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15651              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15652 #else
15653          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15654              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15655              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15656              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15657 #endif
15658            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15659          else
15660             ees=0
15661             evdw1=0
15662             eel_loc=0
15663             eello_turn3=0
15664             eello_turn4=0
15665          endif
15666       else
15667 !        write (iout,*) "Soft-spheer ELEC potential"
15668         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15669          eello_turn4)
15670       endif
15671 !
15672 ! Calculate excluded-volume interaction energy between peptide groups
15673 ! and side chains.
15674 !
15675       if (ipot.lt.6) then
15676        if(wscp.gt.0d0) then
15677         call escp_long(evdw2,evdw2_14)
15678        else
15679         evdw2=0
15680         evdw2_14=0
15681        endif
15682       else
15683         call escp_soft_sphere(evdw2,evdw2_14)
15684       endif
15685 !
15686 ! 12/1/95 Multi-body terms
15687 !
15688       n_corr=0
15689       n_corr1=0
15690       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15691           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15692          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15693 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15694 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15695       else
15696          ecorr=0.0d0
15697          ecorr5=0.0d0
15698          ecorr6=0.0d0
15699          eturn6=0.0d0
15700       endif
15701       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15702          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15703       endif
15704 !
15705 ! If performing constraint dynamics, call the constraint energy
15706 !  after the equilibration time
15707       if(usampl.and.totT.gt.eq_time) then
15708          call EconstrQ
15709          call Econstr_back
15710       else
15711          Uconst=0.0d0
15712          Uconst_back=0.0d0
15713       endif
15714 !
15715 ! Sum the energies
15716 !
15717       do i=1,n_ene
15718         energia(i)=0.0d0
15719       enddo
15720       energia(1)=evdw
15721 #ifdef SCP14
15722       energia(2)=evdw2-evdw2_14
15723       energia(18)=evdw2_14
15724 #else
15725       energia(2)=evdw2
15726       energia(18)=0.0d0
15727 #endif
15728 #ifdef SPLITELE
15729       energia(3)=ees
15730       energia(16)=evdw1
15731 #else
15732       energia(3)=ees+evdw1
15733       energia(16)=0.0d0
15734 #endif
15735       energia(4)=ecorr
15736       energia(5)=ecorr5
15737       energia(6)=ecorr6
15738       energia(7)=eel_loc
15739       energia(8)=eello_turn3
15740       energia(9)=eello_turn4
15741       energia(10)=eturn6
15742       energia(20)=Uconst+Uconst_back
15743       call sum_energy(energia,.true.)
15744 !      write (iout,*) "Exit ETOTAL_LONG"
15745       call flush(iout)
15746       return
15747       end subroutine etotal_long
15748 !-----------------------------------------------------------------------------
15749       subroutine etotal_short(energia)
15750 !
15751 ! Compute the short-range fast-varying contributions to the energy
15752 !
15753 !      implicit real*8 (a-h,o-z)
15754 !      include 'DIMENSIONS'
15755 #ifndef ISNAN
15756       external proc_proc
15757 #ifdef WINPGI
15758 !MS$ATTRIBUTES C ::  proc_proc
15759 #endif
15760 #endif
15761 #ifdef MPI
15762       include "mpif.h"
15763       integer :: ierror,ierr
15764       real(kind=8),dimension(n_ene) :: weights_
15765       real(kind=8) :: time00
15766 #endif
15767 !      include 'COMMON.SETUP'
15768 !      include 'COMMON.IOUNITS'
15769 !      include 'COMMON.FFIELD'
15770 !      include 'COMMON.DERIV'
15771 !      include 'COMMON.INTERACT'
15772 !      include 'COMMON.SBRIDGE'
15773 !      include 'COMMON.CHAIN'
15774 !      include 'COMMON.VAR'
15775 !      include 'COMMON.LOCAL'
15776       real(kind=8),dimension(0:n_ene) :: energia
15777 !el local variables
15778       integer :: i,nres6
15779       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15780       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15781       nres6=6*nres
15782
15783 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15784 !      call flush(iout)
15785       if (modecalc.eq.12.or.modecalc.eq.14) then
15786 #ifdef MPI
15787         if (fg_rank.eq.0) call int_from_cart1(.false.)
15788 #else
15789         call int_from_cart1(.false.)
15790 #endif
15791       endif
15792 #ifdef MPI
15793 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15794 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15795 !      call flush(iout)
15796       if (nfgtasks.gt.1) then
15797         time00=MPI_Wtime()
15798 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15799         if (fg_rank.eq.0) then
15800           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15801 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15802 !          call flush(iout)
15803 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15804 ! FG slaves as WEIGHTS array.
15805           weights_(1)=wsc
15806           weights_(2)=wscp
15807           weights_(3)=welec
15808           weights_(4)=wcorr
15809           weights_(5)=wcorr5
15810           weights_(6)=wcorr6
15811           weights_(7)=wel_loc
15812           weights_(8)=wturn3
15813           weights_(9)=wturn4
15814           weights_(10)=wturn6
15815           weights_(11)=wang
15816           weights_(12)=wscloc
15817           weights_(13)=wtor
15818           weights_(14)=wtor_d
15819           weights_(15)=wstrain
15820           weights_(16)=wvdwpp
15821           weights_(17)=wbond
15822           weights_(18)=scal14
15823           weights_(21)=wsccor
15824 ! FG Master broadcasts the WEIGHTS_ array
15825           call MPI_Bcast(weights_(1),n_ene,&
15826               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15827         else
15828 ! FG slaves receive the WEIGHTS array
15829           call MPI_Bcast(weights(1),n_ene,&
15830               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15831           wsc=weights(1)
15832           wscp=weights(2)
15833           welec=weights(3)
15834           wcorr=weights(4)
15835           wcorr5=weights(5)
15836           wcorr6=weights(6)
15837           wel_loc=weights(7)
15838           wturn3=weights(8)
15839           wturn4=weights(9)
15840           wturn6=weights(10)
15841           wang=weights(11)
15842           wscloc=weights(12)
15843           wtor=weights(13)
15844           wtor_d=weights(14)
15845           wstrain=weights(15)
15846           wvdwpp=weights(16)
15847           wbond=weights(17)
15848           scal14=weights(18)
15849           wsccor=weights(21)
15850         endif
15851 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15852         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15853           king,FG_COMM,IERR)
15854 !        write (iout,*) "Processor",myrank," BROADCAST c"
15855         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15856           king,FG_COMM,IERR)
15857 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15858         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15859           king,FG_COMM,IERR)
15860 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15861         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15862           king,FG_COMM,IERR)
15863 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15864         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15865           king,FG_COMM,IERR)
15866 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15867         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15868           king,FG_COMM,IERR)
15869 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15870         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15871           king,FG_COMM,IERR)
15872 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15873         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15874           king,FG_COMM,IERR)
15875 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15876         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15877           king,FG_COMM,IERR)
15878          time_Bcast=time_Bcast+MPI_Wtime()-time00
15879 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15880       endif
15881 !      write (iout,*) 'Processor',myrank,
15882 !     &  ' calling etotal_short ipot=',ipot
15883 !      call flush(iout)
15884 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15885 #endif
15886 !      call int_from_cart1(.false.)
15887 !
15888 ! Compute the side-chain and electrostatic interaction energy
15889 !
15890       goto (101,102,103,104,105,106) ipot
15891 ! Lennard-Jones potential.
15892   101 call elj_short(evdw)
15893 !d    print '(a)','Exit ELJ'
15894       goto 107
15895 ! Lennard-Jones-Kihara potential (shifted).
15896   102 call eljk_short(evdw)
15897       goto 107
15898 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15899   103 call ebp_short(evdw)
15900       goto 107
15901 ! Gay-Berne potential (shifted LJ, angular dependence).
15902   104 call egb_short(evdw)
15903       goto 107
15904 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15905   105 call egbv_short(evdw)
15906       goto 107
15907 ! Soft-sphere potential - already dealt with in the long-range part
15908   106 evdw=0.0d0
15909 !  106 call e_softsphere_short(evdw)
15910 !
15911 ! Calculate electrostatic (H-bonding) energy of the main chain.
15912 !
15913   107 continue
15914 !
15915 ! Calculate the short-range part of Evdwpp
15916 !
15917       call evdwpp_short(evdw1)
15918 !
15919 ! Calculate the short-range part of ESCp
15920 !
15921       if (ipot.lt.6) then
15922         call escp_short(evdw2,evdw2_14)
15923       endif
15924 !
15925 ! Calculate the bond-stretching energy
15926 !
15927       call ebond(estr)
15928 !
15929 ! Calculate the disulfide-bridge and other energy and the contributions
15930 ! from other distance constraints.
15931       call edis(ehpb)
15932 !
15933 ! Calculate the virtual-bond-angle energy.
15934 !
15935       call ebend(ebe,ethetacnstr)
15936 !
15937 ! Calculate the SC local energy.
15938 !
15939       call vec_and_deriv
15940       call esc(escloc)
15941 !
15942 ! Calculate the virtual-bond torsional energy.
15943 !
15944       call etor(etors,edihcnstr)
15945 !
15946 ! 6/23/01 Calculate double-torsional energy
15947 !
15948       call etor_d(etors_d)
15949 !
15950 ! 21/5/07 Calculate local sicdechain correlation energy
15951 !
15952       if (wsccor.gt.0.0d0) then
15953         call eback_sc_corr(esccor)
15954       else
15955         esccor=0.0d0
15956       endif
15957 !
15958 ! Put energy components into an array
15959 !
15960       do i=1,n_ene
15961         energia(i)=0.0d0
15962       enddo
15963       energia(1)=evdw
15964 #ifdef SCP14
15965       energia(2)=evdw2-evdw2_14
15966       energia(18)=evdw2_14
15967 #else
15968       energia(2)=evdw2
15969       energia(18)=0.0d0
15970 #endif
15971 #ifdef SPLITELE
15972       energia(16)=evdw1
15973 #else
15974       energia(3)=evdw1
15975 #endif
15976       energia(11)=ebe
15977       energia(12)=escloc
15978       energia(13)=etors
15979       energia(14)=etors_d
15980       energia(15)=ehpb
15981       energia(17)=estr
15982       energia(19)=edihcnstr
15983       energia(21)=esccor
15984 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15985       call flush(iout)
15986       call sum_energy(energia,.true.)
15987 !      write (iout,*) "Exit ETOTAL_SHORT"
15988       call flush(iout)
15989       return
15990       end subroutine etotal_short
15991 !-----------------------------------------------------------------------------
15992 ! gnmr1.f
15993 !-----------------------------------------------------------------------------
15994       real(kind=8) function gnmr1(y,ymin,ymax)
15995 !      implicit none
15996       real(kind=8) :: y,ymin,ymax
15997       real(kind=8) :: wykl=4.0d0
15998       if (y.lt.ymin) then
15999         gnmr1=(ymin-y)**wykl/wykl
16000       else if (y.gt.ymax) then
16001         gnmr1=(y-ymax)**wykl/wykl
16002       else
16003         gnmr1=0.0d0
16004       endif
16005       return
16006       end function gnmr1
16007 !-----------------------------------------------------------------------------
16008       real(kind=8) function gnmr1prim(y,ymin,ymax)
16009 !      implicit none
16010       real(kind=8) :: y,ymin,ymax
16011       real(kind=8) :: wykl=4.0d0
16012       if (y.lt.ymin) then
16013         gnmr1prim=-(ymin-y)**(wykl-1)
16014       else if (y.gt.ymax) then
16015         gnmr1prim=(y-ymax)**(wykl-1)
16016       else
16017         gnmr1prim=0.0d0
16018       endif
16019       return
16020       end function gnmr1prim
16021 !----------------------------------------------------------------------------
16022       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16023       real(kind=8) y,ymin,ymax,sigma
16024       real(kind=8) wykl /4.0d0/
16025       if (y.lt.ymin) then
16026         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16027       else if (y.gt.ymax) then
16028         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16029       else
16030         rlornmr1=0.0d0
16031       endif
16032       return
16033       end function rlornmr1
16034 !------------------------------------------------------------------------------
16035       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16036       real(kind=8) y,ymin,ymax,sigma
16037       real(kind=8) wykl /4.0d0/
16038       if (y.lt.ymin) then
16039         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16040         ((ymin-y)**wykl+sigma**wykl)**2
16041       else if (y.gt.ymax) then
16042         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16043         ((y-ymax)**wykl+sigma**wykl)**2
16044       else
16045         rlornmr1prim=0.0d0
16046       endif
16047       return
16048       end function rlornmr1prim
16049
16050       real(kind=8) function harmonic(y,ymax)
16051 !      implicit none
16052       real(kind=8) :: y,ymax
16053       real(kind=8) :: wykl=2.0d0
16054       harmonic=(y-ymax)**wykl
16055       return
16056       end function harmonic
16057 !-----------------------------------------------------------------------------
16058       real(kind=8) function harmonicprim(y,ymax)
16059       real(kind=8) :: y,ymin,ymax
16060       real(kind=8) :: wykl=2.0d0
16061       harmonicprim=(y-ymax)*wykl
16062       return
16063       end function harmonicprim
16064 !-----------------------------------------------------------------------------
16065 ! gradient_p.F
16066 !-----------------------------------------------------------------------------
16067       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16068
16069       use io_base, only:intout,briefout
16070 !      implicit real*8 (a-h,o-z)
16071 !      include 'DIMENSIONS'
16072 !      include 'COMMON.CHAIN'
16073 !      include 'COMMON.DERIV'
16074 !      include 'COMMON.VAR'
16075 !      include 'COMMON.INTERACT'
16076 !      include 'COMMON.FFIELD'
16077 !      include 'COMMON.MD'
16078 !      include 'COMMON.IOUNITS'
16079       real(kind=8),external :: ufparm
16080       integer :: uiparm(1)
16081       real(kind=8) :: urparm(1)
16082       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16083       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16084       integer :: n,nf,ind,ind1,i,k,j
16085 !
16086 ! This subroutine calculates total internal coordinate gradient.
16087 ! Depending on the number of function evaluations, either whole energy
16088 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16089 ! internal coordinates are reevaluated or only the cartesian-in-internal
16090 ! coordinate derivatives are evaluated. The subroutine was designed to work
16091 ! with SUMSL.
16092 !
16093 !
16094       icg=mod(nf,2)+1
16095
16096 !d      print *,'grad',nf,icg
16097       if (nf-nfl+1) 20,30,40
16098    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16099 !    write (iout,*) 'grad 20'
16100       if (nf.eq.0) return
16101       goto 40
16102    30 call var_to_geom(n,x)
16103       call chainbuild
16104 !    write (iout,*) 'grad 30'
16105 !
16106 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16107 !
16108    40 call cartder
16109 !     write (iout,*) 'grad 40'
16110 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16111 !
16112 ! Convert the Cartesian gradient into internal-coordinate gradient.
16113 !
16114       ind=0
16115       ind1=0
16116       do i=1,nres-2
16117       gthetai=0.0D0
16118       gphii=0.0D0
16119       do j=i+1,nres-1
16120           ind=ind+1
16121 !         ind=indmat(i,j)
16122 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16123         do k=1,3
16124             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16125           enddo
16126         do k=1,3
16127           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16128           enddo
16129         enddo
16130       do j=i+1,nres-1
16131           ind1=ind1+1
16132 !         ind1=indmat(i,j)
16133 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16134         do k=1,3
16135           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16136           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16137           enddo
16138         enddo
16139       if (i.gt.1) g(i-1)=gphii
16140       if (n.gt.nphi) g(nphi+i)=gthetai
16141       enddo
16142       if (n.le.nphi+ntheta) goto 10
16143       do i=2,nres-1
16144       if (itype(i,1).ne.10) then
16145           galphai=0.0D0
16146         gomegai=0.0D0
16147         do k=1,3
16148           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16149           enddo
16150         do k=1,3
16151           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16152           enddo
16153           g(ialph(i,1))=galphai
16154         g(ialph(i,1)+nside)=gomegai
16155         endif
16156       enddo
16157 !
16158 ! Add the components corresponding to local energy terms.
16159 !
16160    10 continue
16161       do i=1,nvar
16162 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16163         g(i)=g(i)+gloc(i,icg)
16164       enddo
16165 ! Uncomment following three lines for diagnostics.
16166 !d    call intout
16167 !elwrite(iout,*) "in gradient after calling intout"
16168 !d    call briefout(0,0.0d0)
16169 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16170       return
16171       end subroutine gradient
16172 !-----------------------------------------------------------------------------
16173       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16174
16175       use comm_chu
16176 !      implicit real*8 (a-h,o-z)
16177 !      include 'DIMENSIONS'
16178 !      include 'COMMON.DERIV'
16179 !      include 'COMMON.IOUNITS'
16180 !      include 'COMMON.GEO'
16181       integer :: n,nf
16182 !el      integer :: jjj
16183 !el      common /chuju/ jjj
16184       real(kind=8) :: energia(0:n_ene)
16185       integer :: uiparm(1)
16186       real(kind=8) :: urparm(1)
16187       real(kind=8) :: f
16188       real(kind=8),external :: ufparm
16189       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16190 !     if (jjj.gt.0) then
16191 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16192 !     endif
16193       nfl=nf
16194       icg=mod(nf,2)+1
16195 !d      print *,'func',nf,nfl,icg
16196       call var_to_geom(n,x)
16197       call zerograd
16198       call chainbuild
16199 !d    write (iout,*) 'ETOTAL called from FUNC'
16200       call etotal(energia)
16201       call sum_gradient
16202       f=energia(0)
16203 !     if (jjj.gt.0) then
16204 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16205 !       write (iout,*) 'f=',etot
16206 !       jjj=0
16207 !     endif
16208       return
16209       end subroutine func
16210 !-----------------------------------------------------------------------------
16211       subroutine cartgrad
16212 !      implicit real*8 (a-h,o-z)
16213 !      include 'DIMENSIONS'
16214       use energy_data
16215       use MD_data, only: totT,usampl,eq_time
16216 #ifdef MPI
16217       include 'mpif.h'
16218 #endif
16219 !      include 'COMMON.CHAIN'
16220 !      include 'COMMON.DERIV'
16221 !      include 'COMMON.VAR'
16222 !      include 'COMMON.INTERACT'
16223 !      include 'COMMON.FFIELD'
16224 !      include 'COMMON.MD'
16225 !      include 'COMMON.IOUNITS'
16226 !      include 'COMMON.TIME1'
16227 !
16228       integer :: i,j
16229
16230 ! This subrouting calculates total Cartesian coordinate gradient.
16231 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16232 !
16233 !el#define DEBUG
16234 #ifdef TIMING
16235       time00=MPI_Wtime()
16236 #endif
16237       icg=1
16238       call sum_gradient
16239 #ifdef TIMING
16240 #endif
16241 !el      write (iout,*) "After sum_gradient"
16242 #ifdef DEBUG
16243 !el      write (iout,*) "After sum_gradient"
16244       do i=1,nres-1
16245         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16246         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16247       enddo
16248 #endif
16249 ! If performing constraint dynamics, add the gradients of the constraint energy
16250       if(usampl.and.totT.gt.eq_time) then
16251          do i=1,nct
16252            do j=1,3
16253              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16254              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16255            enddo
16256          enddo
16257          do i=1,nres-3
16258            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16259          enddo
16260          do i=1,nres-2
16261            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16262          enddo
16263       endif
16264 !elwrite (iout,*) "After sum_gradient"
16265 #ifdef TIMING
16266       time01=MPI_Wtime()
16267 #endif
16268       call intcartderiv
16269 !elwrite (iout,*) "After sum_gradient"
16270 #ifdef TIMING
16271       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16272 #endif
16273 !     call checkintcartgrad
16274 !     write(iout,*) 'calling int_to_cart'
16275 #ifdef DEBUG
16276       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16277 #endif
16278       do i=0,nct
16279         do j=1,3
16280           gcart(j,i)=gradc(j,i,icg)
16281           gxcart(j,i)=gradx(j,i,icg)
16282 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16283         enddo
16284 #ifdef DEBUG
16285         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16286           (gxcart(j,i),j=1,3),gloc(i,icg)
16287 #endif
16288       enddo
16289 #ifdef TIMING
16290       time01=MPI_Wtime()
16291 #endif
16292 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16293       call int_to_cart
16294 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16295
16296 #ifdef TIMING
16297             time_inttocart=time_inttocart+MPI_Wtime()-time01
16298 #endif
16299 #ifdef DEBUG
16300             write (iout,*) "gcart and gxcart after int_to_cart"
16301             do i=0,nres-1
16302             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16303                 (gxcart(j,i),j=1,3)
16304             enddo
16305 #endif
16306 #ifdef CARGRAD
16307 #ifdef DEBUG
16308             write (iout,*) "CARGRAD"
16309 #endif
16310             do i=nres,0,-1
16311             do j=1,3
16312               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16313       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16314             enddo
16315       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16316       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16317             enddo
16318       ! Correction: dummy residues
16319             if (nnt.gt.1) then
16320               do j=1,3
16321       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16322                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16323               enddo
16324             endif
16325             if (nct.lt.nres) then
16326               do j=1,3
16327       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16328                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16329               enddo
16330             endif
16331 #endif
16332 #ifdef TIMING
16333             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16334 #endif
16335       !el#undef DEBUG
16336             return
16337             end subroutine cartgrad
16338       !-----------------------------------------------------------------------------
16339             subroutine zerograd
16340       !      implicit real*8 (a-h,o-z)
16341       !      include 'DIMENSIONS'
16342       !      include 'COMMON.DERIV'
16343       !      include 'COMMON.CHAIN'
16344       !      include 'COMMON.VAR'
16345       !      include 'COMMON.MD'
16346       !      include 'COMMON.SCCOR'
16347       !
16348       !el local variables
16349             integer :: i,j,intertyp,k
16350       ! Initialize Cartesian-coordinate gradient
16351       !
16352       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16353       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16354
16355       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16356       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16357       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16358       !      allocate(gradcorr_long(3,nres))
16359       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16360       !      allocate(gcorr6_turn_long(3,nres))
16361       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16362
16363       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16364
16365       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16366       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16367
16368       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16369       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16370
16371       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16372       !      allocate(gscloc(3,nres)) !(3,maxres)
16373       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16374
16375
16376
16377       !      common /deriv_scloc/
16378       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16379       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16380       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16381       !      common /mpgrad/
16382       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16383
16384
16385
16386       !          gradc(j,i,icg)=0.0d0
16387       !          gradx(j,i,icg)=0.0d0
16388
16389       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16390       !elwrite(iout,*) "icg",icg
16391             do i=-1,nres
16392             do j=1,3
16393               gvdwx(j,i)=0.0D0
16394               gradx_scp(j,i)=0.0D0
16395               gvdwc(j,i)=0.0D0
16396               gvdwc_scp(j,i)=0.0D0
16397               gvdwc_scpp(j,i)=0.0d0
16398               gelc(j,i)=0.0D0
16399               gelc_long(j,i)=0.0D0
16400               gradb(j,i)=0.0d0
16401               gradbx(j,i)=0.0d0
16402               gvdwpp(j,i)=0.0d0
16403               gel_loc(j,i)=0.0d0
16404               gel_loc_long(j,i)=0.0d0
16405               ghpbc(j,i)=0.0D0
16406               ghpbx(j,i)=0.0D0
16407               gcorr3_turn(j,i)=0.0d0
16408               gcorr4_turn(j,i)=0.0d0
16409               gradcorr(j,i)=0.0d0
16410               gradcorr_long(j,i)=0.0d0
16411               gradcorr5_long(j,i)=0.0d0
16412               gradcorr6_long(j,i)=0.0d0
16413               gcorr6_turn_long(j,i)=0.0d0
16414               gradcorr5(j,i)=0.0d0
16415               gradcorr6(j,i)=0.0d0
16416               gcorr6_turn(j,i)=0.0d0
16417               gsccorc(j,i)=0.0d0
16418               gsccorx(j,i)=0.0d0
16419               gradc(j,i,icg)=0.0d0
16420               gradx(j,i,icg)=0.0d0
16421               gscloc(j,i)=0.0d0
16422               gsclocx(j,i)=0.0d0
16423               gliptran(j,i)=0.0d0
16424               gliptranx(j,i)=0.0d0
16425               gliptranc(j,i)=0.0d0
16426               gshieldx(j,i)=0.0d0
16427               gshieldc(j,i)=0.0d0
16428               gshieldc_loc(j,i)=0.0d0
16429               gshieldx_ec(j,i)=0.0d0
16430               gshieldc_ec(j,i)=0.0d0
16431               gshieldc_loc_ec(j,i)=0.0d0
16432               gshieldx_t3(j,i)=0.0d0
16433               gshieldc_t3(j,i)=0.0d0
16434               gshieldc_loc_t3(j,i)=0.0d0
16435               gshieldx_t4(j,i)=0.0d0
16436               gshieldc_t4(j,i)=0.0d0
16437               gshieldc_loc_t4(j,i)=0.0d0
16438               gshieldx_ll(j,i)=0.0d0
16439               gshieldc_ll(j,i)=0.0d0
16440               gshieldc_loc_ll(j,i)=0.0d0
16441               gg_tube(j,i)=0.0d0
16442               gg_tube_sc(j,i)=0.0d0
16443               gradafm(j,i)=0.0d0
16444               gradb_nucl(j,i)=0.0d0
16445               gradbx_nucl(j,i)=0.0d0
16446               gvdwpp_nucl(j,i)=0.0d0
16447               gvdwpp(j,i)=0.0d0
16448               gelpp(j,i)=0.0d0
16449               gvdwpsb(j,i)=0.0d0
16450               gvdwpsb1(j,i)=0.0d0
16451               gvdwsbc(j,i)=0.0d0
16452               gvdwsbx(j,i)=0.0d0
16453               gelsbc(j,i)=0.0d0
16454               gradcorr_nucl(j,i)=0.0d0
16455               gradcorr3_nucl(j,i)=0.0d0
16456               gradxorr_nucl(j,i)=0.0d0
16457               gradxorr3_nucl(j,i)=0.0d0
16458               gelsbx(j,i)=0.0d0
16459               gsbloc(j,i)=0.0d0
16460               gsblocx(j,i)=0.0d0
16461               gradpepcat(j,i)=0.0d0
16462               gradpepcatx(j,i)=0.0d0
16463               gradcatcat(j,i)=0.0d0
16464               gvdwx_scbase(j,i)=0.0d0
16465               gvdwc_scbase(j,i)=0.0d0
16466               gvdwx_pepbase(j,i)=0.0d0
16467               gvdwc_pepbase(j,i)=0.0d0
16468               gvdwx_scpho(j,i)=0.0d0
16469               gvdwc_scpho(j,i)=0.0d0
16470               gvdwc_peppho(j,i)=0.0d0
16471             enddo
16472              enddo
16473             do i=0,nres
16474             do j=1,3
16475               do intertyp=1,3
16476                gloc_sc(intertyp,i,icg)=0.0d0
16477               enddo
16478             enddo
16479             enddo
16480             do i=1,nres
16481              do j=1,maxcontsshi
16482              shield_list(j,i)=0
16483             do k=1,3
16484       !C           print *,i,j,k
16485                grad_shield_side(k,j,i)=0.0d0
16486                grad_shield_loc(k,j,i)=0.0d0
16487              enddo
16488              enddo
16489              ishield_list(i)=0
16490             enddo
16491
16492       !
16493       ! Initialize the gradient of local energy terms.
16494       !
16495       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16496       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16497       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16498       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16499       !      allocate(gel_loc_turn3(nres))
16500       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16501       !      allocate(gsccor_loc(nres))      !(maxres)
16502
16503             do i=1,4*nres
16504             gloc(i,icg)=0.0D0
16505             enddo
16506             do i=1,nres
16507             gel_loc_loc(i)=0.0d0
16508             gcorr_loc(i)=0.0d0
16509             g_corr5_loc(i)=0.0d0
16510             g_corr6_loc(i)=0.0d0
16511             gel_loc_turn3(i)=0.0d0
16512             gel_loc_turn4(i)=0.0d0
16513             gel_loc_turn6(i)=0.0d0
16514             gsccor_loc(i)=0.0d0
16515             enddo
16516       ! initialize gcart and gxcart
16517       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16518             do i=0,nres
16519             do j=1,3
16520               gcart(j,i)=0.0d0
16521               gxcart(j,i)=0.0d0
16522             enddo
16523             enddo
16524             return
16525             end subroutine zerograd
16526       !-----------------------------------------------------------------------------
16527             real(kind=8) function fdum()
16528             fdum=0.0D0
16529             return
16530             end function fdum
16531       !-----------------------------------------------------------------------------
16532       ! intcartderiv.F
16533       !-----------------------------------------------------------------------------
16534             subroutine intcartderiv
16535       !      implicit real*8 (a-h,o-z)
16536       !      include 'DIMENSIONS'
16537 #ifdef MPI
16538             include 'mpif.h'
16539 #endif
16540       !      include 'COMMON.SETUP'
16541       !      include 'COMMON.CHAIN'
16542       !      include 'COMMON.VAR'
16543       !      include 'COMMON.GEO'
16544       !      include 'COMMON.INTERACT'
16545       !      include 'COMMON.DERIV'
16546       !      include 'COMMON.IOUNITS'
16547       !      include 'COMMON.LOCAL'
16548       !      include 'COMMON.SCCOR'
16549             real(kind=8) :: pi4,pi34
16550             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16551             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16552                       dcosomega,dsinomega !(3,3,maxres)
16553             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16554
16555             integer :: i,j,k
16556             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16557                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16558                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16559                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16560             integer :: nres2
16561             nres2=2*nres
16562
16563       !el from module energy-------------
16564       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16565       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16566       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16567
16568       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16569       !el      allocate(dsintau(3,3,3,0:nres2))
16570       !el      allocate(dtauangle(3,3,3,0:nres2))
16571       !el      allocate(domicron(3,2,2,0:nres2))
16572       !el      allocate(dcosomicron(3,2,2,0:nres2))
16573
16574
16575
16576 #if defined(MPI) && defined(PARINTDER)
16577             if (nfgtasks.gt.1 .and. me.eq.king) &
16578             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16579 #endif
16580             pi4 = 0.5d0*pipol
16581             pi34 = 3*pi4
16582
16583       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16584       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16585
16586       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16587             do i=1,nres
16588             do j=1,3
16589               dtheta(j,1,i)=0.0d0
16590               dtheta(j,2,i)=0.0d0
16591               dphi(j,1,i)=0.0d0
16592               dphi(j,2,i)=0.0d0
16593               dphi(j,3,i)=0.0d0
16594             enddo
16595             enddo
16596       ! Derivatives of theta's
16597 #if defined(MPI) && defined(PARINTDER)
16598       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16599             do i=max0(ithet_start-1,3),ithet_end
16600 #else
16601             do i=3,nres
16602 #endif
16603             cost=dcos(theta(i))
16604             sint=sqrt(1-cost*cost)
16605             do j=1,3
16606               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16607               vbld(i-1)
16608               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16609               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16610               vbld(i)
16611               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16612             enddo
16613             enddo
16614 #if defined(MPI) && defined(PARINTDER)
16615       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16616             do i=max0(ithet_start-1,3),ithet_end
16617 #else
16618             do i=3,nres
16619 #endif
16620             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16621             cost1=dcos(omicron(1,i))
16622             sint1=sqrt(1-cost1*cost1)
16623             cost2=dcos(omicron(2,i))
16624             sint2=sqrt(1-cost2*cost2)
16625              do j=1,3
16626       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16627               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16628               cost1*dc_norm(j,i-2))/ &
16629               vbld(i-1)
16630               domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16631               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16632               +cost1*(dc_norm(j,i-1+nres)))/ &
16633               vbld(i-1+nres)
16634               domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16635       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16636       !C Looks messy but better than if in loop
16637               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16638               +cost2*dc_norm(j,i-1))/ &
16639               vbld(i)
16640               domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16641               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16642                +cost2*(-dc_norm(j,i-1+nres)))/ &
16643               vbld(i-1+nres)
16644       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16645               domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16646             enddo
16647              endif
16648             enddo
16649       !elwrite(iout,*) "after vbld write"
16650       ! Derivatives of phi:
16651       ! If phi is 0 or 180 degrees, then the formulas
16652       ! have to be derived by power series expansion of the
16653       ! conventional formulas around 0 and 180.
16654 #ifdef PARINTDER
16655             do i=iphi1_start,iphi1_end
16656 #else
16657             do i=4,nres
16658 #endif
16659       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16660       ! the conventional case
16661             sint=dsin(theta(i))
16662             sint1=dsin(theta(i-1))
16663             sing=dsin(phi(i))
16664             cost=dcos(theta(i))
16665             cost1=dcos(theta(i-1))
16666             cosg=dcos(phi(i))
16667             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16668             fac0=1.0d0/(sint1*sint)
16669             fac1=cost*fac0
16670             fac2=cost1*fac0
16671             fac3=cosg*cost1/(sint1*sint1)
16672             fac4=cosg*cost/(sint*sint)
16673       !    Obtaining the gamma derivatives from sine derivative
16674              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16675                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16676                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16677              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16678              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16679              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16680              do j=1,3
16681                 ctgt=cost/sint
16682                 ctgt1=cost1/sint1
16683                 cosg_inv=1.0d0/cosg
16684                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16685                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16686                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16687                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16688                 dsinphi(j,2,i)= &
16689                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16690                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16691                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16692                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16693                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16694       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16695                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16696                 endif
16697       ! Bug fixed 3/24/05 (AL)
16698              enddo
16699       !   Obtaining the gamma derivatives from cosine derivative
16700             else
16701                do j=1,3
16702                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16703                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16704                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16705                dc_norm(j,i-3))/vbld(i-2)
16706                dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16707                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16708                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16709                dcostheta(j,1,i)
16710                dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16711                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16712                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16713                dc_norm(j,i-1))/vbld(i)
16714                dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16715                endif
16716              enddo
16717             endif
16718             enddo
16719       !alculate derivative of Tauangle
16720 #ifdef PARINTDER
16721             do i=itau_start,itau_end
16722 #else
16723             do i=3,nres
16724       !elwrite(iout,*) " vecpr",i,nres
16725 #endif
16726              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16727       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16728       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16729       !c dtauangle(j,intertyp,dervityp,residue number)
16730       !c INTERTYP=1 SC...Ca...Ca..Ca
16731       ! the conventional case
16732             sint=dsin(theta(i))
16733             sint1=dsin(omicron(2,i-1))
16734             sing=dsin(tauangle(1,i))
16735             cost=dcos(theta(i))
16736             cost1=dcos(omicron(2,i-1))
16737             cosg=dcos(tauangle(1,i))
16738       !elwrite(iout,*) " vecpr5",i,nres
16739             do j=1,3
16740       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16741       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16742             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16743       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16744             enddo
16745             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16746             fac0=1.0d0/(sint1*sint)
16747             fac1=cost*fac0
16748             fac2=cost1*fac0
16749             fac3=cosg*cost1/(sint1*sint1)
16750             fac4=cosg*cost/(sint*sint)
16751       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16752       !    Obtaining the gamma derivatives from sine derivative
16753              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16754                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16755                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16756              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16757              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16758              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16759             do j=1,3
16760                 ctgt=cost/sint
16761                 ctgt1=cost1/sint1
16762                 cosg_inv=1.0d0/cosg
16763                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16764              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16765              *vbld_inv(i-2+nres)
16766                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16767                 dsintau(j,1,2,i)= &
16768                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16769                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16770       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16771                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16772       ! Bug fixed 3/24/05 (AL)
16773                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16774                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16775       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16776                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16777              enddo
16778       !   Obtaining the gamma derivatives from cosine derivative
16779             else
16780                do j=1,3
16781                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16782                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16783                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16784                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16785                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16786                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16787                dcostheta(j,1,i)
16788                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16789                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16790                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16791                dc_norm(j,i-1))/vbld(i)
16792                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16793       !         write (iout,*) "else",i
16794              enddo
16795             endif
16796       !        do k=1,3
16797       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16798       !        enddo
16799             enddo
16800       !C Second case Ca...Ca...Ca...SC
16801 #ifdef PARINTDER
16802             do i=itau_start,itau_end
16803 #else
16804             do i=4,nres
16805 #endif
16806              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16807               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16808       ! the conventional case
16809             sint=dsin(omicron(1,i))
16810             sint1=dsin(theta(i-1))
16811             sing=dsin(tauangle(2,i))
16812             cost=dcos(omicron(1,i))
16813             cost1=dcos(theta(i-1))
16814             cosg=dcos(tauangle(2,i))
16815       !        do j=1,3
16816       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16817       !        enddo
16818             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16819             fac0=1.0d0/(sint1*sint)
16820             fac1=cost*fac0
16821             fac2=cost1*fac0
16822             fac3=cosg*cost1/(sint1*sint1)
16823             fac4=cosg*cost/(sint*sint)
16824       !    Obtaining the gamma derivatives from sine derivative
16825              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16826                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16827                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16828              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16829              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16830              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16831             do j=1,3
16832                 ctgt=cost/sint
16833                 ctgt1=cost1/sint1
16834                 cosg_inv=1.0d0/cosg
16835                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16836                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16837       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16838       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16839                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16840                 dsintau(j,2,2,i)= &
16841                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16842                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16843       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16844       !     & sing*ctgt*domicron(j,1,2,i),
16845       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16846                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16847       ! Bug fixed 3/24/05 (AL)
16848                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16849                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16850       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16851                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16852              enddo
16853       !   Obtaining the gamma derivatives from cosine derivative
16854             else
16855                do j=1,3
16856                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16857                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16858                dc_norm(j,i-3))/vbld(i-2)
16859                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16860                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16861                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16862                dcosomicron(j,1,1,i)
16863                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16864                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16865                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16866                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16867                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16868       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16869              enddo
16870             endif
16871             enddo
16872
16873       !CC third case SC...Ca...Ca...SC
16874 #ifdef PARINTDER
16875
16876             do i=itau_start,itau_end
16877 #else
16878             do i=3,nres
16879 #endif
16880       ! the conventional case
16881             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16882             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16883             sint=dsin(omicron(1,i))
16884             sint1=dsin(omicron(2,i-1))
16885             sing=dsin(tauangle(3,i))
16886             cost=dcos(omicron(1,i))
16887             cost1=dcos(omicron(2,i-1))
16888             cosg=dcos(tauangle(3,i))
16889             do j=1,3
16890             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16891       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16892             enddo
16893             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16894             fac0=1.0d0/(sint1*sint)
16895             fac1=cost*fac0
16896             fac2=cost1*fac0
16897             fac3=cosg*cost1/(sint1*sint1)
16898             fac4=cosg*cost/(sint*sint)
16899       !    Obtaining the gamma derivatives from sine derivative
16900              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16901                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16902                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16903              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16904              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16905              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16906             do j=1,3
16907                 ctgt=cost/sint
16908                 ctgt1=cost1/sint1
16909                 cosg_inv=1.0d0/cosg
16910                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16911                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16912                   *vbld_inv(i-2+nres)
16913                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16914                 dsintau(j,3,2,i)= &
16915                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16916                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16917                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16918       ! Bug fixed 3/24/05 (AL)
16919                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16920                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16921                   *vbld_inv(i-1+nres)
16922       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16923                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16924              enddo
16925       !   Obtaining the gamma derivatives from cosine derivative
16926             else
16927                do j=1,3
16928                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16929                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16930                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16931                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16932                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16933                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16934                dcosomicron(j,1,1,i)
16935                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16936                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16937                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16938                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16939                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16940       !          write(iout,*) "else",i
16941              enddo
16942             endif
16943             enddo
16944
16945 #ifdef CRYST_SC
16946       !   Derivatives of side-chain angles alpha and omega
16947 #if defined(MPI) && defined(PARINTDER)
16948             do i=ibond_start,ibond_end
16949 #else
16950             do i=2,nres-1
16951 #endif
16952               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16953                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16954                  fac6=fac5/vbld(i)
16955                  fac7=fac5*fac5
16956                  fac8=fac5/vbld(i+1)
16957                  fac9=fac5/vbld(i+nres)
16958                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16959                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16960                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16961                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16962                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16963                  sina=sqrt(1-cosa*cosa)
16964                  sino=dsin(omeg(i))
16965       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16966                  do j=1,3
16967                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16968                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16969                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16970                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16971                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16972                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16973                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16974                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16975                   vbld(i+nres))
16976                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16977                 enddo
16978       ! obtaining the derivatives of omega from sines
16979                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16980                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16981                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16982                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16983                    dsin(theta(i+1)))
16984                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16985                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16986                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16987                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16988                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16989                    coso_inv=1.0d0/dcos(omeg(i))
16990                    do j=1,3
16991                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16992                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16993                    (sino*dc_norm(j,i-1))/vbld(i)
16994                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16995                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16996                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16997                    -sino*dc_norm(j,i)/vbld(i+1)
16998                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16999                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17000                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17001                    vbld(i+nres)
17002                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17003                   enddo
17004                else
17005       !   obtaining the derivatives of omega from cosines
17006                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17007                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17008                  fac12=fac10*sina
17009                  fac13=fac12*fac12
17010                  fac14=sina*sina
17011                  do j=1,3
17012                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17013                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17014                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17015                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17016                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17017                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17018                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17019                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17020                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17021                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17022                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17023                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17024                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17025                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17026                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17027                 enddo
17028               endif
17029              else
17030                do j=1,3
17031                  do k=1,3
17032                    dalpha(k,j,i)=0.0d0
17033                    domega(k,j,i)=0.0d0
17034                  enddo
17035                enddo
17036              endif
17037              enddo
17038 #endif
17039 #if defined(MPI) && defined(PARINTDER)
17040             if (nfgtasks.gt.1) then
17041 #ifdef DEBUG
17042       !d      write (iout,*) "Gather dtheta"
17043       !d      call flush(iout)
17044             write (iout,*) "dtheta before gather"
17045             do i=1,nres
17046             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17047             enddo
17048 #endif
17049             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17050             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17051             king,FG_COMM,IERROR)
17052 #ifdef DEBUG
17053       !d      write (iout,*) "Gather dphi"
17054       !d      call flush(iout)
17055             write (iout,*) "dphi before gather"
17056             do i=1,nres
17057             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17058             enddo
17059 #endif
17060             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17061             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17062             king,FG_COMM,IERROR)
17063       !d      write (iout,*) "Gather dalpha"
17064       !d      call flush(iout)
17065 #ifdef CRYST_SC
17066             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17067             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17068             king,FG_COMM,IERROR)
17069       !d      write (iout,*) "Gather domega"
17070       !d      call flush(iout)
17071             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17072             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17073             king,FG_COMM,IERROR)
17074 #endif
17075             endif
17076 #endif
17077 #ifdef DEBUG
17078             write (iout,*) "dtheta after gather"
17079             do i=1,nres
17080             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17081             enddo
17082             write (iout,*) "dphi after gather"
17083             do i=1,nres
17084             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17085             enddo
17086             write (iout,*) "dalpha after gather"
17087             do i=1,nres
17088             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17089             enddo
17090             write (iout,*) "domega after gather"
17091             do i=1,nres
17092             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17093             enddo
17094 #endif
17095             return
17096             end subroutine intcartderiv
17097       !-----------------------------------------------------------------------------
17098             subroutine checkintcartgrad
17099       !      implicit real*8 (a-h,o-z)
17100       !      include 'DIMENSIONS'
17101 #ifdef MPI
17102             include 'mpif.h'
17103 #endif
17104       !      include 'COMMON.CHAIN'
17105       !      include 'COMMON.VAR'
17106       !      include 'COMMON.GEO'
17107       !      include 'COMMON.INTERACT'
17108       !      include 'COMMON.DERIV'
17109       !      include 'COMMON.IOUNITS'
17110       !      include 'COMMON.SETUP'
17111             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17112             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17113             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17114             real(kind=8),dimension(3) :: dc_norm_s
17115             real(kind=8) :: aincr=1.0d-5
17116             integer :: i,j
17117             real(kind=8) :: dcji
17118             do i=1,nres
17119             phi_s(i)=phi(i)
17120             theta_s(i)=theta(i)
17121             alph_s(i)=alph(i)
17122             omeg_s(i)=omeg(i)
17123             enddo
17124       ! Check theta gradient
17125             write (iout,*) &
17126              "Analytical (upper) and numerical (lower) gradient of theta"
17127             write (iout,*)
17128             do i=3,nres
17129             do j=1,3
17130               dcji=dc(j,i-2)
17131               dc(j,i-2)=dcji+aincr
17132               call chainbuild_cart
17133               call int_from_cart1(.false.)
17134           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17135           dc(j,i-2)=dcji
17136           dcji=dc(j,i-1)
17137           dc(j,i-1)=dc(j,i-1)+aincr
17138           call chainbuild_cart
17139           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17140           dc(j,i-1)=dcji
17141         enddo
17142 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17143 !el          (dtheta(j,2,i),j=1,3)
17144 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17145 !el          (dthetanum(j,2,i),j=1,3)
17146 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17147 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17148 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17149 !el        write (iout,*)
17150       enddo
17151 ! Check gamma gradient
17152       write (iout,*) &
17153        "Analytical (upper) and numerical (lower) gradient of gamma"
17154       do i=4,nres
17155         do j=1,3
17156           dcji=dc(j,i-3)
17157           dc(j,i-3)=dcji+aincr
17158           call chainbuild_cart
17159           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17160               dc(j,i-3)=dcji
17161           dcji=dc(j,i-2)
17162           dc(j,i-2)=dcji+aincr
17163           call chainbuild_cart
17164           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17165           dc(j,i-2)=dcji
17166           dcji=dc(j,i-1)
17167           dc(j,i-1)=dc(j,i-1)+aincr
17168           call chainbuild_cart
17169           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17170           dc(j,i-1)=dcji
17171         enddo
17172 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17173 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17174 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17175 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17176 !el        write (iout,'(5x,3(3f10.5,5x))') &
17177 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17178 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17179 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17180 !el        write (iout,*)
17181       enddo
17182 ! Check alpha gradient
17183       write (iout,*) &
17184        "Analytical (upper) and numerical (lower) gradient of alpha"
17185       do i=2,nres-1
17186        if(itype(i,1).ne.10) then
17187                  do j=1,3
17188                   dcji=dc(j,i-1)
17189                    dc(j,i-1)=dcji+aincr
17190               call chainbuild_cart
17191               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17192                  /aincr
17193                   dc(j,i-1)=dcji
17194               dcji=dc(j,i)
17195               dc(j,i)=dcji+aincr
17196               call chainbuild_cart
17197               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17198                  /aincr
17199               dc(j,i)=dcji
17200               dcji=dc(j,i+nres)
17201               dc(j,i+nres)=dc(j,i+nres)+aincr
17202               call chainbuild_cart
17203               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17204                  /aincr
17205              dc(j,i+nres)=dcji
17206             enddo
17207           endif
17208 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17209 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17210 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17211 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17212 !el        write (iout,'(5x,3(3f10.5,5x))') &
17213 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17214 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17215 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17216 !el        write (iout,*)
17217       enddo
17218 !     Check omega gradient
17219       write (iout,*) &
17220        "Analytical (upper) and numerical (lower) gradient of omega"
17221       do i=2,nres-1
17222        if(itype(i,1).ne.10) then
17223                  do j=1,3
17224                   dcji=dc(j,i-1)
17225                    dc(j,i-1)=dcji+aincr
17226               call chainbuild_cart
17227               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17228                  /aincr
17229                   dc(j,i-1)=dcji
17230               dcji=dc(j,i)
17231               dc(j,i)=dcji+aincr
17232               call chainbuild_cart
17233               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17234                  /aincr
17235               dc(j,i)=dcji
17236               dcji=dc(j,i+nres)
17237               dc(j,i+nres)=dc(j,i+nres)+aincr
17238               call chainbuild_cart
17239               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17240                  /aincr
17241              dc(j,i+nres)=dcji
17242             enddo
17243           endif
17244 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17245 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17246 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17247 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17248 !el        write (iout,'(5x,3(3f10.5,5x))') &
17249 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17250 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17251 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17252 !el        write (iout,*)
17253       enddo
17254       return
17255       end subroutine checkintcartgrad
17256 !-----------------------------------------------------------------------------
17257 ! q_measure.F
17258 !-----------------------------------------------------------------------------
17259       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17260 !      implicit real*8 (a-h,o-z)
17261 !      include 'DIMENSIONS'
17262 !      include 'COMMON.IOUNITS'
17263 !      include 'COMMON.CHAIN'
17264 !      include 'COMMON.INTERACT'
17265 !      include 'COMMON.VAR'
17266       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17267       integer :: kkk,nsep=3
17268       real(kind=8) :: qm      !dist,
17269       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17270       logical :: lprn=.false.
17271       logical :: flag
17272 !      real(kind=8) :: sigm,x
17273
17274 !el      sigm(x)=0.25d0*x     ! local function
17275       qqmax=1.0d10
17276       do kkk=1,nperm
17277       qq = 0.0d0
17278       nl=0
17279        if(flag) then
17280         do il=seg1+nsep,seg2
17281           do jl=seg1,il-nsep
17282             nl=nl+1
17283             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17284                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17285                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17286             dij=dist(il,jl)
17287             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17288             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17289               nl=nl+1
17290               d0ijCM=dsqrt( &
17291                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17292                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17293                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17294               dijCM=dist(il+nres,jl+nres)
17295               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17296             endif
17297             qq = qq+qqij+qqijCM
17298           enddo
17299         enddo
17300         qq = qq/nl
17301       else
17302       do il=seg1,seg2
17303         if((seg3-il).lt.3) then
17304              secseg=il+3
17305         else
17306              secseg=seg3
17307         endif
17308           do jl=secseg,seg4
17309             nl=nl+1
17310             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17311                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17312                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17313             dij=dist(il,jl)
17314             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17315             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17316               nl=nl+1
17317               d0ijCM=dsqrt( &
17318                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17319                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17320                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17321               dijCM=dist(il+nres,jl+nres)
17322               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17323             endif
17324             qq = qq+qqij+qqijCM
17325           enddo
17326         enddo
17327       qq = qq/nl
17328       endif
17329       if (qqmax.le.qq) qqmax=qq
17330       enddo
17331       qwolynes=1.0d0-qqmax
17332       return
17333       end function qwolynes
17334 !-----------------------------------------------------------------------------
17335       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17336 !      implicit real*8 (a-h,o-z)
17337 !      include 'DIMENSIONS'
17338 !      include 'COMMON.IOUNITS'
17339 !      include 'COMMON.CHAIN'
17340 !      include 'COMMON.INTERACT'
17341 !      include 'COMMON.VAR'
17342 !      include 'COMMON.MD'
17343       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17344       integer :: nsep=3, kkk
17345 !el      real(kind=8) :: dist
17346       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17347       logical :: lprn=.false.
17348       logical :: flag
17349       real(kind=8) :: sim,dd0,fac,ddqij
17350 !el      sigm(x)=0.25d0*x           ! local function
17351       do kkk=1,nperm
17352       do i=0,nres
17353         do j=1,3
17354           dqwol(j,i)=0.0d0
17355           dxqwol(j,i)=0.0d0
17356         enddo
17357       enddo
17358       nl=0
17359        if(flag) then
17360         do il=seg1+nsep,seg2
17361           do jl=seg1,il-nsep
17362             nl=nl+1
17363             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17364                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17365                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17366             dij=dist(il,jl)
17367             sim = 1.0d0/sigm(d0ij)
17368             sim = sim*sim
17369             dd0 = dij-d0ij
17370             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17371           do k=1,3
17372               ddqij = (c(k,il)-c(k,jl))*fac
17373               dqwol(k,il)=dqwol(k,il)+ddqij
17374               dqwol(k,jl)=dqwol(k,jl)-ddqij
17375             enddo
17376
17377             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17378               nl=nl+1
17379               d0ijCM=dsqrt( &
17380                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17381                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17382                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17383               dijCM=dist(il+nres,jl+nres)
17384               sim = 1.0d0/sigm(d0ijCM)
17385               sim = sim*sim
17386               dd0=dijCM-d0ijCM
17387               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17388               do k=1,3
17389                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17390                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17391                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17392               enddo
17393             endif
17394           enddo
17395         enddo
17396        else
17397         do il=seg1,seg2
17398         if((seg3-il).lt.3) then
17399              secseg=il+3
17400         else
17401              secseg=seg3
17402         endif
17403           do jl=secseg,seg4
17404             nl=nl+1
17405             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17406                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17407                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17408             dij=dist(il,jl)
17409             sim = 1.0d0/sigm(d0ij)
17410             sim = sim*sim
17411             dd0 = dij-d0ij
17412             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17413             do k=1,3
17414               ddqij = (c(k,il)-c(k,jl))*fac
17415               dqwol(k,il)=dqwol(k,il)+ddqij
17416               dqwol(k,jl)=dqwol(k,jl)-ddqij
17417             enddo
17418             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17419               nl=nl+1
17420               d0ijCM=dsqrt( &
17421                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17422                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17423                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17424               dijCM=dist(il+nres,jl+nres)
17425               sim = 1.0d0/sigm(d0ijCM)
17426               sim=sim*sim
17427               dd0 = dijCM-d0ijCM
17428               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17429               do k=1,3
17430                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17431                dxqwol(k,il)=dxqwol(k,il)+ddqij
17432                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17433               enddo
17434             endif
17435           enddo
17436         enddo
17437       endif
17438       enddo
17439        do i=0,nres
17440          do j=1,3
17441            dqwol(j,i)=dqwol(j,i)/nl
17442            dxqwol(j,i)=dxqwol(j,i)/nl
17443          enddo
17444        enddo
17445       return
17446       end subroutine qwolynes_prim
17447 !-----------------------------------------------------------------------------
17448       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17449 !      implicit real*8 (a-h,o-z)
17450 !      include 'DIMENSIONS'
17451 !      include 'COMMON.IOUNITS'
17452 !      include 'COMMON.CHAIN'
17453 !      include 'COMMON.INTERACT'
17454 !      include 'COMMON.VAR'
17455       integer :: seg1,seg2,seg3,seg4
17456       logical :: flag
17457       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17458       real(kind=8),dimension(3,0:2*nres) :: cdummy
17459       real(kind=8) :: q1,q2
17460       real(kind=8) :: delta=1.0d-10
17461       integer :: i,j
17462
17463       do i=0,nres
17464         do j=1,3
17465           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17466           cdummy(j,i)=c(j,i)
17467           c(j,i)=c(j,i)+delta
17468           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17469           qwolan(j,i)=(q2-q1)/delta
17470           c(j,i)=cdummy(j,i)
17471         enddo
17472       enddo
17473       do i=0,nres
17474         do j=1,3
17475           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17476           cdummy(j,i+nres)=c(j,i+nres)
17477           c(j,i+nres)=c(j,i+nres)+delta
17478           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17479           qwolxan(j,i)=(q2-q1)/delta
17480           c(j,i+nres)=cdummy(j,i+nres)
17481         enddo
17482       enddo
17483 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17484 !      do i=0,nct
17485 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17486 !      enddo
17487 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17488 !      do i=0,nct
17489 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17490 !      enddo
17491       return
17492       end subroutine qwol_num
17493 !-----------------------------------------------------------------------------
17494       subroutine EconstrQ
17495 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17496 !      implicit real*8 (a-h,o-z)
17497 !      include 'DIMENSIONS'
17498 !      include 'COMMON.CONTROL'
17499 !      include 'COMMON.VAR'
17500 !      include 'COMMON.MD'
17501       use MD_data
17502 !#ifndef LANG0
17503 !      include 'COMMON.LANGEVIN'
17504 !#else
17505 !      include 'COMMON.LANGEVIN.lang0'
17506 !#endif
17507 !      include 'COMMON.CHAIN'
17508 !      include 'COMMON.DERIV'
17509 !      include 'COMMON.GEO'
17510 !      include 'COMMON.LOCAL'
17511 !      include 'COMMON.INTERACT'
17512 !      include 'COMMON.IOUNITS'
17513 !      include 'COMMON.NAMES'
17514 !      include 'COMMON.TIME1'
17515       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17516       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17517                    duconst,duxconst
17518       integer :: kstart,kend,lstart,lend,idummy
17519       real(kind=8) :: delta=1.0d-7
17520       integer :: i,j,k,ii
17521       do i=0,nres
17522          do j=1,3
17523             duconst(j,i)=0.0d0
17524             dudconst(j,i)=0.0d0
17525             duxconst(j,i)=0.0d0
17526             dudxconst(j,i)=0.0d0
17527          enddo
17528       enddo
17529       Uconst=0.0d0
17530       do i=1,nfrag
17531          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17532            idummy,idummy)
17533          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17534 ! Calculating the derivatives of Constraint energy with respect to Q
17535          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17536            qinfrag(i,iset))
17537 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17538 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17539 !         hmnum=(hm2-hm1)/delta
17540 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17541 !     &   qinfrag(i,iset))
17542 !         write(iout,*) "harmonicnum frag", hmnum
17543 ! Calculating the derivatives of Q with respect to cartesian coordinates
17544          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17545           idummy,idummy)
17546 !         write(iout,*) "dqwol "
17547 !         do ii=1,nres
17548 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17549 !         enddo
17550 !         write(iout,*) "dxqwol "
17551 !         do ii=1,nres
17552 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17553 !         enddo
17554 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17555 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17556 !     &  ,idummy,idummy)
17557 !  The gradients of Uconst in Cs
17558          do ii=0,nres
17559             do j=1,3
17560                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17561                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17562             enddo
17563          enddo
17564       enddo
17565       do i=1,npair
17566          kstart=ifrag(1,ipair(1,i,iset),iset)
17567          kend=ifrag(2,ipair(1,i,iset),iset)
17568          lstart=ifrag(1,ipair(2,i,iset),iset)
17569          lend=ifrag(2,ipair(2,i,iset),iset)
17570          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17571          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17572 !  Calculating dU/dQ
17573          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17574 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17575 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17576 !         hmnum=(hm2-hm1)/delta
17577 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17578 !     &   qinpair(i,iset))
17579 !         write(iout,*) "harmonicnum pair ", hmnum
17580 ! Calculating dQ/dXi
17581          call qwolynes_prim(kstart,kend,.false.,&
17582           lstart,lend)
17583 !         write(iout,*) "dqwol "
17584 !         do ii=1,nres
17585 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17586 !         enddo
17587 !         write(iout,*) "dxqwol "
17588 !         do ii=1,nres
17589 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17590 !        enddo
17591 ! Calculating numerical gradients
17592 !        call qwol_num(kstart,kend,.false.
17593 !     &  ,lstart,lend)
17594 ! The gradients of Uconst in Cs
17595          do ii=0,nres
17596             do j=1,3
17597                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17598                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17599             enddo
17600          enddo
17601       enddo
17602 !      write(iout,*) "Uconst inside subroutine ", Uconst
17603 ! Transforming the gradients from Cs to dCs for the backbone
17604       do i=0,nres
17605          do j=i+1,nres
17606            do k=1,3
17607              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17608            enddo
17609          enddo
17610       enddo
17611 !  Transforming the gradients from Cs to dCs for the side chains
17612       do i=1,nres
17613          do j=1,3
17614            dudxconst(j,i)=duxconst(j,i)
17615          enddo
17616       enddo
17617 !      write(iout,*) "dU/ddc backbone "
17618 !       do ii=0,nres
17619 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17620 !      enddo
17621 !      write(iout,*) "dU/ddX side chain "
17622 !      do ii=1,nres
17623 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17624 !      enddo
17625 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17626 !      call dEconstrQ_num
17627       return
17628       end subroutine EconstrQ
17629 !-----------------------------------------------------------------------------
17630       subroutine dEconstrQ_num
17631 ! Calculating numerical dUconst/ddc and dUconst/ddx
17632 !      implicit real*8 (a-h,o-z)
17633 !      include 'DIMENSIONS'
17634 !      include 'COMMON.CONTROL'
17635 !      include 'COMMON.VAR'
17636 !      include 'COMMON.MD'
17637       use MD_data
17638 !#ifndef LANG0
17639 !      include 'COMMON.LANGEVIN'
17640 !#else
17641 !      include 'COMMON.LANGEVIN.lang0'
17642 !#endif
17643 !      include 'COMMON.CHAIN'
17644 !      include 'COMMON.DERIV'
17645 !      include 'COMMON.GEO'
17646 !      include 'COMMON.LOCAL'
17647 !      include 'COMMON.INTERACT'
17648 !      include 'COMMON.IOUNITS'
17649 !      include 'COMMON.NAMES'
17650 !      include 'COMMON.TIME1'
17651       real(kind=8) :: uzap1,uzap2
17652       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17653       integer :: kstart,kend,lstart,lend,idummy
17654       real(kind=8) :: delta=1.0d-7
17655 !el local variables
17656       integer :: i,ii,j
17657 !     real(kind=8) ::
17658 !     For the backbone
17659       do i=0,nres-1
17660          do j=1,3
17661             dUcartan(j,i)=0.0d0
17662             cdummy(j,i)=dc(j,i)
17663             dc(j,i)=dc(j,i)+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)=cdummy(j,i)
17682             call chainbuild_cart
17683             uzap1=0.0d0
17684              do ii=1,nfrag
17685              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17686                 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             ducartan(j,i)=(uzap2-uzap1)/(delta)
17700          enddo
17701       enddo
17702 ! Calculating numerical gradients for dU/ddx
17703       do i=0,nres-1
17704          duxcartan(j,i)=0.0d0
17705          do j=1,3
17706             cdummy(j,i)=dc(j,i+nres)
17707             dc(j,i+nres)=dc(j,i+nres)+delta
17708             call chainbuild_cart
17709           uzap2=0.0d0
17710             do ii=1,nfrag
17711              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17712                 idummy,idummy)
17713                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17714                 qinfrag(ii,iset))
17715             enddo
17716             do ii=1,npair
17717                kstart=ifrag(1,ipair(1,ii,iset),iset)
17718                kend=ifrag(2,ipair(1,ii,iset),iset)
17719                lstart=ifrag(1,ipair(2,ii,iset),iset)
17720                lend=ifrag(2,ipair(2,ii,iset),iset)
17721                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17722                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17723                 qinpair(ii,iset))
17724             enddo
17725             dc(j,i+nres)=cdummy(j,i)
17726             call chainbuild_cart
17727             uzap1=0.0d0
17728              do ii=1,nfrag
17729                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17730                 ifrag(2,ii,iset),.true.,idummy,idummy)
17731                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17732                 qinfrag(ii,iset))
17733             enddo
17734             do ii=1,npair
17735                kstart=ifrag(1,ipair(1,ii,iset),iset)
17736                kend=ifrag(2,ipair(1,ii,iset),iset)
17737                lstart=ifrag(1,ipair(2,ii,iset),iset)
17738                lend=ifrag(2,ipair(2,ii,iset),iset)
17739                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17740                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17741                 qinpair(ii,iset))
17742             enddo
17743             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17744          enddo
17745       enddo
17746       write(iout,*) "Numerical dUconst/ddc backbone "
17747       do ii=0,nres
17748         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17749       enddo
17750 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17751 !      do ii=1,nres
17752 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17753 !      enddo
17754       return
17755       end subroutine dEconstrQ_num
17756 !-----------------------------------------------------------------------------
17757 ! ssMD.F
17758 !-----------------------------------------------------------------------------
17759       subroutine check_energies
17760
17761 !      use random, only: ran_number
17762
17763 !      implicit none
17764 !     Includes
17765 !      include 'DIMENSIONS'
17766 !      include 'COMMON.CHAIN'
17767 !      include 'COMMON.VAR'
17768 !      include 'COMMON.IOUNITS'
17769 !      include 'COMMON.SBRIDGE'
17770 !      include 'COMMON.LOCAL'
17771 !      include 'COMMON.GEO'
17772
17773 !     External functions
17774 !EL      double precision ran_number
17775 !EL      external ran_number
17776
17777 !     Local variables
17778       integer :: i,j,k,l,lmax,p,pmax
17779       real(kind=8) :: rmin,rmax
17780       real(kind=8) :: eij
17781
17782       real(kind=8) :: d
17783       real(kind=8) :: wi,rij,tj,pj
17784 !      return
17785
17786       i=5
17787       j=14
17788
17789       d=dsc(1)
17790       rmin=2.0D0
17791       rmax=12.0D0
17792
17793       lmax=10000
17794       pmax=1
17795
17796       do k=1,3
17797         c(k,i)=0.0D0
17798         c(k,j)=0.0D0
17799         c(k,nres+i)=0.0D0
17800         c(k,nres+j)=0.0D0
17801       enddo
17802
17803       do l=1,lmax
17804
17805 !t        wi=ran_number(0.0D0,pi)
17806 !        wi=ran_number(0.0D0,pi/6.0D0)
17807 !        wi=0.0D0
17808 !t        tj=ran_number(0.0D0,pi)
17809 !t        pj=ran_number(0.0D0,pi)
17810 !        pj=ran_number(0.0D0,pi/6.0D0)
17811 !        pj=0.0D0
17812
17813         do p=1,pmax
17814 !t           rij=ran_number(rmin,rmax)
17815
17816            c(1,j)=d*sin(pj)*cos(tj)
17817            c(2,j)=d*sin(pj)*sin(tj)
17818            c(3,j)=d*cos(pj)
17819
17820            c(3,nres+i)=-rij
17821
17822            c(1,i)=d*sin(wi)
17823            c(3,i)=-rij-d*cos(wi)
17824
17825            do k=1,3
17826               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17827               dc_norm(k,nres+i)=dc(k,nres+i)/d
17828               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17829               dc_norm(k,nres+j)=dc(k,nres+j)/d
17830            enddo
17831
17832            call dyn_ssbond_ene(i,j,eij)
17833         enddo
17834       enddo
17835       call exit(1)
17836       return
17837       end subroutine check_energies
17838 !-----------------------------------------------------------------------------
17839       subroutine dyn_ssbond_ene(resi,resj,eij)
17840 !      implicit none
17841 !      Includes
17842       use calc_data
17843       use comm_sschecks
17844 !      include 'DIMENSIONS'
17845 !      include 'COMMON.SBRIDGE'
17846 !      include 'COMMON.CHAIN'
17847 !      include 'COMMON.DERIV'
17848 !      include 'COMMON.LOCAL'
17849 !      include 'COMMON.INTERACT'
17850 !      include 'COMMON.VAR'
17851 !      include 'COMMON.IOUNITS'
17852 !      include 'COMMON.CALC'
17853 #ifndef CLUST
17854 #ifndef WHAM
17855        use MD_data
17856 !      include 'COMMON.MD'
17857 !      use MD, only: totT,t_bath
17858 #endif
17859 #endif
17860 !     External functions
17861 !EL      double precision h_base
17862 !EL      external h_base
17863
17864 !     Input arguments
17865       integer :: resi,resj
17866
17867 !     Output arguments
17868       real(kind=8) :: eij
17869
17870 !     Local variables
17871       logical :: havebond
17872       integer itypi,itypj
17873       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17874       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17875       real(kind=8),dimension(3) :: dcosom1,dcosom2
17876       real(kind=8) :: ed
17877       real(kind=8) :: pom1,pom2
17878       real(kind=8) :: ljA,ljB,ljXs
17879       real(kind=8),dimension(1:3) :: d_ljB
17880       real(kind=8) :: ssA,ssB,ssC,ssXs
17881       real(kind=8) :: ssxm,ljxm,ssm,ljm
17882       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17883       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17884       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17885 !-------FIRST METHOD
17886       real(kind=8) :: xm
17887       real(kind=8),dimension(1:3) :: d_xm
17888 !-------END FIRST METHOD
17889 !-------SECOND METHOD
17890 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17891 !-------END SECOND METHOD
17892
17893 !-------TESTING CODE
17894 !el      logical :: checkstop,transgrad
17895 !el      common /sschecks/ checkstop,transgrad
17896
17897       integer :: icheck,nicheck,jcheck,njcheck
17898       real(kind=8),dimension(-1:1) :: echeck
17899       real(kind=8) :: deps,ssx0,ljx0
17900 !-------END TESTING CODE
17901
17902       eij=0.0d0
17903       i=resi
17904       j=resj
17905
17906 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17907 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17908
17909       itypi=itype(i,1)
17910       dxi=dc_norm(1,nres+i)
17911       dyi=dc_norm(2,nres+i)
17912       dzi=dc_norm(3,nres+i)
17913       dsci_inv=vbld_inv(i+nres)
17914
17915       itypj=itype(j,1)
17916       xj=c(1,nres+j)-c(1,nres+i)
17917       yj=c(2,nres+j)-c(2,nres+i)
17918       zj=c(3,nres+j)-c(3,nres+i)
17919       dxj=dc_norm(1,nres+j)
17920       dyj=dc_norm(2,nres+j)
17921       dzj=dc_norm(3,nres+j)
17922       dscj_inv=vbld_inv(j+nres)
17923
17924       chi1=chi(itypi,itypj)
17925       chi2=chi(itypj,itypi)
17926       chi12=chi1*chi2
17927       chip1=chip(itypi)
17928       chip2=chip(itypj)
17929       chip12=chip1*chip2
17930       alf1=alp(itypi)
17931       alf2=alp(itypj)
17932       alf12=0.5D0*(alf1+alf2)
17933
17934       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17935       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17936 !     The following are set in sc_angular
17937 !      erij(1)=xj*rij
17938 !      erij(2)=yj*rij
17939 !      erij(3)=zj*rij
17940 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17941 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17942 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17943       call sc_angular
17944       rij=1.0D0/rij  ! Reset this so it makes sense
17945
17946       sig0ij=sigma(itypi,itypj)
17947       sig=sig0ij*dsqrt(1.0D0/sigsq)
17948
17949       ljXs=sig-sig0ij
17950       ljA=eps1*eps2rt**2*eps3rt**2
17951       ljB=ljA*bb_aq(itypi,itypj)
17952       ljA=ljA*aa_aq(itypi,itypj)
17953       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17954
17955       ssXs=d0cm
17956       deltat1=1.0d0-om1
17957       deltat2=1.0d0+om2
17958       deltat12=om2-om1+2.0d0
17959       cosphi=om12-om1*om2
17960       ssA=akcm
17961       ssB=akct*deltat12
17962       ssC=ss_depth &
17963            +akth*(deltat1*deltat1+deltat2*deltat2) &
17964            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17965       ssxm=ssXs-0.5D0*ssB/ssA
17966
17967 !-------TESTING CODE
17968 !$$$c     Some extra output
17969 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17970 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17971 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17972 !$$$      if (ssx0.gt.0.0d0) then
17973 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17974 !$$$      else
17975 !$$$        ssx0=ssxm
17976 !$$$      endif
17977 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17978 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17979 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17980 !$$$      return
17981 !-------END TESTING CODE
17982
17983 !-------TESTING CODE
17984 !     Stop and plot energy and derivative as a function of distance
17985       if (checkstop) then
17986         ssm=ssC-0.25D0*ssB*ssB/ssA
17987         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17988         if (ssm.lt.ljm .and. &
17989              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17990           nicheck=1000
17991           njcheck=1
17992           deps=0.5d-7
17993         else
17994           checkstop=.false.
17995         endif
17996       endif
17997       if (.not.checkstop) then
17998         nicheck=0
17999         njcheck=-1
18000       endif
18001
18002       do icheck=0,nicheck
18003       do jcheck=-1,njcheck
18004       if (checkstop) rij=(ssxm-1.0d0)+ &
18005              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18006 !-------END TESTING CODE
18007
18008       if (rij.gt.ljxm) then
18009         havebond=.false.
18010         ljd=rij-ljXs
18011         fac=(1.0D0/ljd)**expon
18012         e1=fac*fac*aa_aq(itypi,itypj)
18013         e2=fac*bb_aq(itypi,itypj)
18014         eij=eps1*eps2rt*eps3rt*(e1+e2)
18015         eps2der=eij*eps3rt
18016         eps3der=eij*eps2rt
18017         eij=eij*eps2rt*eps3rt
18018
18019         sigder=-sig/sigsq
18020         e1=e1*eps1*eps2rt**2*eps3rt**2
18021         ed=-expon*(e1+eij)/ljd
18022         sigder=ed*sigder
18023         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18024         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18025         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18026              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18027       else if (rij.lt.ssxm) then
18028         havebond=.true.
18029         ssd=rij-ssXs
18030         eij=ssA*ssd*ssd+ssB*ssd+ssC
18031
18032         ed=2*akcm*ssd+akct*deltat12
18033         pom1=akct*ssd
18034         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18035         eom1=-2*akth*deltat1-pom1-om2*pom2
18036         eom2= 2*akth*deltat2+pom1-om1*pom2
18037         eom12=pom2
18038       else
18039         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18040
18041         d_ssxm(1)=0.5D0*akct/ssA
18042         d_ssxm(2)=-d_ssxm(1)
18043         d_ssxm(3)=0.0D0
18044
18045         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18046         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18047         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18048         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18049
18050 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18051         xm=0.5d0*(ssxm+ljxm)
18052         do k=1,3
18053           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18054         enddo
18055         if (rij.lt.xm) then
18056           havebond=.true.
18057           ssm=ssC-0.25D0*ssB*ssB/ssA
18058           d_ssm(1)=0.5D0*akct*ssB/ssA
18059           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18060           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18061           d_ssm(3)=omega
18062           f1=(rij-xm)/(ssxm-xm)
18063           f2=(rij-ssxm)/(xm-ssxm)
18064           h1=h_base(f1,hd1)
18065           h2=h_base(f2,hd2)
18066           eij=ssm*h1+Ht*h2
18067           delta_inv=1.0d0/(xm-ssxm)
18068           deltasq_inv=delta_inv*delta_inv
18069           fac=ssm*hd1-Ht*hd2
18070           fac1=deltasq_inv*fac*(xm-rij)
18071           fac2=deltasq_inv*fac*(rij-ssxm)
18072           ed=delta_inv*(Ht*hd2-ssm*hd1)
18073           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18074           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18075           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18076         else
18077           havebond=.false.
18078           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18079           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18080           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18081           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18082                alf12/eps3rt)
18083           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18084           f1=(rij-ljxm)/(xm-ljxm)
18085           f2=(rij-xm)/(ljxm-xm)
18086           h1=h_base(f1,hd1)
18087           h2=h_base(f2,hd2)
18088           eij=Ht*h1+ljm*h2
18089           delta_inv=1.0d0/(ljxm-xm)
18090           deltasq_inv=delta_inv*delta_inv
18091           fac=Ht*hd1-ljm*hd2
18092           fac1=deltasq_inv*fac*(ljxm-rij)
18093           fac2=deltasq_inv*fac*(rij-xm)
18094           ed=delta_inv*(ljm*hd2-Ht*hd1)
18095           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18096           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18097           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18098         endif
18099 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18100
18101 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18102 !$$$        ssd=rij-ssXs
18103 !$$$        ljd=rij-ljXs
18104 !$$$        fac1=rij-ljxm
18105 !$$$        fac2=rij-ssxm
18106 !$$$
18107 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18108 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18109 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18110 !$$$
18111 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18112 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18113 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18114 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18115 !$$$        d_ssm(3)=omega
18116 !$$$
18117 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18118 !$$$        do k=1,3
18119 !$$$          d_ljm(k)=ljm*d_ljB(k)
18120 !$$$        enddo
18121 !$$$        ljm=ljm*ljB
18122 !$$$
18123 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18124 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18125 !$$$        d_ss(2)=akct*ssd
18126 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18127 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18128 !$$$        d_ss(3)=omega
18129 !$$$
18130 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18131 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18132 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18133 !$$$        do k=1,3
18134 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18135 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18136 !$$$        enddo
18137 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18138 !$$$
18139 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18140 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18141 !$$$        h1=h_base(f1,hd1)
18142 !$$$        h2=h_base(f2,hd2)
18143 !$$$        eij=ss*h1+ljf*h2
18144 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18145 !$$$        deltasq_inv=delta_inv*delta_inv
18146 !$$$        fac=ljf*hd2-ss*hd1
18147 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18148 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18149 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18150 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18151 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18152 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18153 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18154 !$$$
18155 !$$$        havebond=.false.
18156 !$$$        if (ed.gt.0.0d0) havebond=.true.
18157 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18158
18159       endif
18160
18161       if (havebond) then
18162 !#ifndef CLUST
18163 !#ifndef WHAM
18164 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18165 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18166 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18167 !        endif
18168 !#endif
18169 !#endif
18170         dyn_ssbond_ij(i,j)=eij
18171       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18172         dyn_ssbond_ij(i,j)=1.0d300
18173 !#ifndef CLUST
18174 !#ifndef WHAM
18175 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18176 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18177 !#endif
18178 !#endif
18179       endif
18180
18181 !-------TESTING CODE
18182 !el      if (checkstop) then
18183         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18184              "CHECKSTOP",rij,eij,ed
18185         echeck(jcheck)=eij
18186 !el      endif
18187       enddo
18188       if (checkstop) then
18189         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18190       endif
18191       enddo
18192       if (checkstop) then
18193         transgrad=.true.
18194         checkstop=.false.
18195       endif
18196 !-------END TESTING CODE
18197
18198       do k=1,3
18199         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18200         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18201       enddo
18202       do k=1,3
18203         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18204       enddo
18205       do k=1,3
18206         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18207              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18208              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18209         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18210              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18211              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18212       enddo
18213 !grad      do k=i,j-1
18214 !grad        do l=1,3
18215 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18216 !grad        enddo
18217 !grad      enddo
18218
18219       do l=1,3
18220         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18221         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18222       enddo
18223
18224       return
18225       end subroutine dyn_ssbond_ene
18226 !--------------------------------------------------------------------------
18227          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18228 !      implicit none
18229 !      Includes
18230       use calc_data
18231       use comm_sschecks
18232 !      include 'DIMENSIONS'
18233 !      include 'COMMON.SBRIDGE'
18234 !      include 'COMMON.CHAIN'
18235 !      include 'COMMON.DERIV'
18236 !      include 'COMMON.LOCAL'
18237 !      include 'COMMON.INTERACT'
18238 !      include 'COMMON.VAR'
18239 !      include 'COMMON.IOUNITS'
18240 !      include 'COMMON.CALC'
18241 #ifndef CLUST
18242 #ifndef WHAM
18243        use MD_data
18244 !      include 'COMMON.MD'
18245 !      use MD, only: totT,t_bath
18246 #endif
18247 #endif
18248       double precision h_base
18249       external h_base
18250
18251 !c     Input arguments
18252       integer resi,resj,resk,m,itypi,itypj,itypk
18253
18254 !c     Output arguments
18255       double precision eij,eij1,eij2,eij3
18256
18257 !c     Local variables
18258       logical havebond
18259 !c      integer itypi,itypj,k,l
18260       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18261       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18262       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18263       double precision sig0ij,ljd,sig,fac,e1,e2
18264       double precision dcosom1(3),dcosom2(3),ed
18265       double precision pom1,pom2
18266       double precision ljA,ljB,ljXs
18267       double precision d_ljB(1:3)
18268       double precision ssA,ssB,ssC,ssXs
18269       double precision ssxm,ljxm,ssm,ljm
18270       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18271       eij=0.0
18272       if (dtriss.eq.0) return
18273       i=resi
18274       j=resj
18275       k=resk
18276 !C      write(iout,*) resi,resj,resk
18277       itypi=itype(i,1)
18278       dxi=dc_norm(1,nres+i)
18279       dyi=dc_norm(2,nres+i)
18280       dzi=dc_norm(3,nres+i)
18281       dsci_inv=vbld_inv(i+nres)
18282       xi=c(1,nres+i)
18283       yi=c(2,nres+i)
18284       zi=c(3,nres+i)
18285       itypj=itype(j,1)
18286       xj=c(1,nres+j)
18287       yj=c(2,nres+j)
18288       zj=c(3,nres+j)
18289
18290       dxj=dc_norm(1,nres+j)
18291       dyj=dc_norm(2,nres+j)
18292       dzj=dc_norm(3,nres+j)
18293       dscj_inv=vbld_inv(j+nres)
18294       itypk=itype(k,1)
18295       xk=c(1,nres+k)
18296       yk=c(2,nres+k)
18297       zk=c(3,nres+k)
18298
18299       dxk=dc_norm(1,nres+k)
18300       dyk=dc_norm(2,nres+k)
18301       dzk=dc_norm(3,nres+k)
18302       dscj_inv=vbld_inv(k+nres)
18303       xij=xj-xi
18304       xik=xk-xi
18305       xjk=xk-xj
18306       yij=yj-yi
18307       yik=yk-yi
18308       yjk=yk-yj
18309       zij=zj-zi
18310       zik=zk-zi
18311       zjk=zk-zj
18312       rrij=(xij*xij+yij*yij+zij*zij)
18313       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18314       rrik=(xik*xik+yik*yik+zik*zik)
18315       rik=dsqrt(rrik)
18316       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18317       rjk=dsqrt(rrjk)
18318 !C there are three combination of distances for each trisulfide bonds
18319 !C The first case the ith atom is the center
18320 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18321 !C distance y is second distance the a,b,c,d are parameters derived for
18322 !C this problem d parameter was set as a penalty currenlty set to 1.
18323       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18324       eij1=0.0d0
18325       else
18326       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18327       endif
18328 !C second case jth atom is center
18329       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18330       eij2=0.0d0
18331       else
18332       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18333       endif
18334 !C the third case kth atom is the center
18335       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18336       eij3=0.0d0
18337       else
18338       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18339       endif
18340 !C      eij2=0.0
18341 !C      eij3=0.0
18342 !C      eij1=0.0
18343       eij=eij1+eij2+eij3
18344 !C      write(iout,*)i,j,k,eij
18345 !C The energy penalty calculated now time for the gradient part
18346 !C derivative over rij
18347       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18348       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18349             gg(1)=xij*fac/rij
18350             gg(2)=yij*fac/rij
18351             gg(3)=zij*fac/rij
18352       do m=1,3
18353         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18354         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18355       enddo
18356
18357       do l=1,3
18358         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18359         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18360       enddo
18361 !C now derivative over rik
18362       fac=-eij1**2/dtriss* &
18363       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18364       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18365             gg(1)=xik*fac/rik
18366             gg(2)=yik*fac/rik
18367             gg(3)=zik*fac/rik
18368       do m=1,3
18369         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18370         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18371       enddo
18372       do l=1,3
18373         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18374         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18375       enddo
18376 !C now derivative over rjk
18377       fac=-eij2**2/dtriss* &
18378       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18379       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18380             gg(1)=xjk*fac/rjk
18381             gg(2)=yjk*fac/rjk
18382             gg(3)=zjk*fac/rjk
18383       do m=1,3
18384         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18385         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18386       enddo
18387       do l=1,3
18388         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18389         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18390       enddo
18391       return
18392       end subroutine triple_ssbond_ene
18393
18394
18395
18396 !-----------------------------------------------------------------------------
18397       real(kind=8) function h_base(x,deriv)
18398 !     A smooth function going 0->1 in range [0,1]
18399 !     It should NOT be called outside range [0,1], it will not work there.
18400       implicit none
18401
18402 !     Input arguments
18403       real(kind=8) :: x
18404
18405 !     Output arguments
18406       real(kind=8) :: deriv
18407
18408 !     Local variables
18409       real(kind=8) :: xsq
18410
18411
18412 !     Two parabolas put together.  First derivative zero at extrema
18413 !$$$      if (x.lt.0.5D0) then
18414 !$$$        h_base=2.0D0*x*x
18415 !$$$        deriv=4.0D0*x
18416 !$$$      else
18417 !$$$        deriv=1.0D0-x
18418 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18419 !$$$        deriv=4.0D0*deriv
18420 !$$$      endif
18421
18422 !     Third degree polynomial.  First derivative zero at extrema
18423       h_base=x*x*(3.0d0-2.0d0*x)
18424       deriv=6.0d0*x*(1.0d0-x)
18425
18426 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18427 !$$$      xsq=x*x
18428 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18429 !$$$      deriv=x-1.0d0
18430 !$$$      deriv=deriv*deriv
18431 !$$$      deriv=30.0d0*xsq*deriv
18432
18433       return
18434       end function h_base
18435 !-----------------------------------------------------------------------------
18436       subroutine dyn_set_nss
18437 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18438 !      implicit none
18439       use MD_data, only: totT,t_bath
18440 !     Includes
18441 !      include 'DIMENSIONS'
18442 #ifdef MPI
18443       include "mpif.h"
18444 #endif
18445 !      include 'COMMON.SBRIDGE'
18446 !      include 'COMMON.CHAIN'
18447 !      include 'COMMON.IOUNITS'
18448 !      include 'COMMON.SETUP'
18449 !      include 'COMMON.MD'
18450 !     Local variables
18451       real(kind=8) :: emin
18452       integer :: i,j,imin,ierr
18453       integer :: diff,allnss,newnss
18454       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18455                 newihpb,newjhpb
18456       logical :: found
18457       integer,dimension(0:nfgtasks) :: i_newnss
18458       integer,dimension(0:nfgtasks) :: displ
18459       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18460       integer :: g_newnss
18461
18462       allnss=0
18463       do i=1,nres-1
18464         do j=i+1,nres
18465           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18466             allnss=allnss+1
18467             allflag(allnss)=0
18468             allihpb(allnss)=i
18469             alljhpb(allnss)=j
18470           endif
18471         enddo
18472       enddo
18473
18474 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18475
18476  1    emin=1.0d300
18477       do i=1,allnss
18478         if (allflag(i).eq.0 .and. &
18479              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18480           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18481           imin=i
18482         endif
18483       enddo
18484       if (emin.lt.1.0d300) then
18485         allflag(imin)=1
18486         do i=1,allnss
18487           if (allflag(i).eq.0 .and. &
18488                (allihpb(i).eq.allihpb(imin) .or. &
18489                alljhpb(i).eq.allihpb(imin) .or. &
18490                allihpb(i).eq.alljhpb(imin) .or. &
18491                alljhpb(i).eq.alljhpb(imin))) then
18492             allflag(i)=-1
18493           endif
18494         enddo
18495         goto 1
18496       endif
18497
18498 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18499
18500       newnss=0
18501       do i=1,allnss
18502         if (allflag(i).eq.1) then
18503           newnss=newnss+1
18504           newihpb(newnss)=allihpb(i)
18505           newjhpb(newnss)=alljhpb(i)
18506         endif
18507       enddo
18508
18509 #ifdef MPI
18510       if (nfgtasks.gt.1)then
18511
18512         call MPI_Reduce(newnss,g_newnss,1,&
18513           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18514         call MPI_Gather(newnss,1,MPI_INTEGER,&
18515                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18516         displ(0)=0
18517         do i=1,nfgtasks-1,1
18518           displ(i)=i_newnss(i-1)+displ(i-1)
18519         enddo
18520         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18521                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18522                          king,FG_COMM,IERR)
18523         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18524                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18525                          king,FG_COMM,IERR)
18526         if(fg_rank.eq.0) then
18527 !         print *,'g_newnss',g_newnss
18528 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18529 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18530          newnss=g_newnss
18531          do i=1,newnss
18532           newihpb(i)=g_newihpb(i)
18533           newjhpb(i)=g_newjhpb(i)
18534          enddo
18535         endif
18536       endif
18537 #endif
18538
18539       diff=newnss-nss
18540
18541 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18542 !       print *,newnss,nss,maxdim
18543       do i=1,nss
18544         found=.false.
18545 !        print *,newnss
18546         do j=1,newnss
18547 !!          print *,j
18548           if (idssb(i).eq.newihpb(j) .and. &
18549                jdssb(i).eq.newjhpb(j)) found=.true.
18550         enddo
18551 #ifndef CLUST
18552 #ifndef WHAM
18553 !        write(iout,*) "found",found,i,j
18554         if (.not.found.and.fg_rank.eq.0) &
18555             write(iout,'(a15,f12.2,f8.1,2i5)') &
18556              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18557 #endif
18558 #endif
18559       enddo
18560
18561       do i=1,newnss
18562         found=.false.
18563         do j=1,nss
18564 !          print *,i,j
18565           if (newihpb(i).eq.idssb(j) .and. &
18566                newjhpb(i).eq.jdssb(j)) found=.true.
18567         enddo
18568 #ifndef CLUST
18569 #ifndef WHAM
18570 !        write(iout,*) "found",found,i,j
18571         if (.not.found.and.fg_rank.eq.0) &
18572             write(iout,'(a15,f12.2,f8.1,2i5)') &
18573              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18574 #endif
18575 #endif
18576       enddo
18577
18578       nss=newnss
18579       do i=1,nss
18580         idssb(i)=newihpb(i)
18581         jdssb(i)=newjhpb(i)
18582       enddo
18583
18584       return
18585       end subroutine dyn_set_nss
18586 ! Lipid transfer energy function
18587       subroutine Eliptransfer(eliptran)
18588 !C this is done by Adasko
18589 !C      print *,"wchodze"
18590 !C structure of box:
18591 !C      water
18592 !C--bordliptop-- buffore starts
18593 !C--bufliptop--- here true lipid starts
18594 !C      lipid
18595 !C--buflipbot--- lipid ends buffore starts
18596 !C--bordlipbot--buffore ends
18597       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18598       integer :: i
18599       eliptran=0.0
18600 !      print *, "I am in eliptran"
18601       do i=ilip_start,ilip_end
18602 !C       do i=1,1
18603         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18604          cycle
18605
18606         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18607         if (positi.le.0.0) positi=positi+boxzsize
18608 !C        print *,i
18609 !C first for peptide groups
18610 !c for each residue check if it is in lipid or lipid water border area
18611        if ((positi.gt.bordlipbot)  &
18612       .and.(positi.lt.bordliptop)) then
18613 !C the energy transfer exist
18614         if (positi.lt.buflipbot) then
18615 !C what fraction I am in
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*pepliptran
18622          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18623          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18624 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18625
18626 !C        print *,"doing sccale for lower part"
18627 !C         print *,i,sslip,fracinbuf,ssgradlip
18628         elseif (positi.gt.bufliptop) then
18629          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18630          sslip=sscalelip(fracinbuf)
18631          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18632          eliptran=eliptran+sslip*pepliptran
18633          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18634          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18635 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18636 !C          print *, "doing sscalefor top part"
18637 !C         print *,i,sslip,fracinbuf,ssgradlip
18638         else
18639          eliptran=eliptran+pepliptran
18640 !C         print *,"I am in true lipid"
18641         endif
18642 !C       else
18643 !C       eliptran=elpitran+0.0 ! I am in water
18644        endif
18645        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18646        enddo
18647 ! here starts the side chain transfer
18648        do i=ilip_start,ilip_end
18649         if (itype(i,1).eq.ntyp1) cycle
18650         positi=(mod(c(3,i+nres),boxzsize))
18651         if (positi.le.0) positi=positi+boxzsize
18652 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18653 !c for each residue check if it is in lipid or lipid water border area
18654 !C       respos=mod(c(3,i+nres),boxzsize)
18655 !C       print *,positi,bordlipbot,buflipbot
18656        if ((positi.gt.bordlipbot) &
18657        .and.(positi.lt.bordliptop)) then
18658 !C the energy transfer exist
18659         if (positi.lt.buflipbot) then
18660          fracinbuf=1.0d0-   &
18661            ((positi-bordlipbot)/lipbufthick)
18662 !C lipbufthick is thickenes of lipid buffore
18663          sslip=sscalelip(fracinbuf)
18664          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18665          eliptran=eliptran+sslip*liptranene(itype(i,1))
18666          gliptranx(3,i)=gliptranx(3,i) &
18667       +ssgradlip*liptranene(itype(i,1))
18668          gliptranc(3,i-1)= gliptranc(3,i-1) &
18669       +ssgradlip*liptranene(itype(i,1))
18670 !C         print *,"doing sccale for lower part"
18671         elseif (positi.gt.bufliptop) then
18672          fracinbuf=1.0d0-  &
18673       ((bordliptop-positi)/lipbufthick)
18674          sslip=sscalelip(fracinbuf)
18675          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18676          eliptran=eliptran+sslip*liptranene(itype(i,1))
18677          gliptranx(3,i)=gliptranx(3,i)  &
18678        +ssgradlip*liptranene(itype(i,1))
18679          gliptranc(3,i-1)= gliptranc(3,i-1) &
18680       +ssgradlip*liptranene(itype(i,1))
18681 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18682         else
18683          eliptran=eliptran+liptranene(itype(i,1))
18684 !C         print *,"I am in true lipid"
18685         endif
18686         endif ! if in lipid or buffor
18687 !C       else
18688 !C       eliptran=elpitran+0.0 ! I am in water
18689         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18690        enddo
18691        return
18692        end  subroutine Eliptransfer
18693 !----------------------------------NANO FUNCTIONS
18694 !C-----------------------------------------------------------------------
18695 !C-----------------------------------------------------------
18696 !C This subroutine is to mimic the histone like structure but as well can be
18697 !C utilizet to nanostructures (infinit) small modification has to be used to
18698 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18699 !C gradient has to be modified at the ends
18700 !C The energy function is Kihara potential
18701 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18702 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18703 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18704 !C simple Kihara potential
18705       subroutine calctube(Etube)
18706       real(kind=8),dimension(3) :: vectube
18707       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18708        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18709        sc_aa_tube,sc_bb_tube
18710       integer :: i,j,iti
18711       Etube=0.0d0
18712       do i=itube_start,itube_end
18713         enetube(i)=0.0d0
18714         enetube(i+nres)=0.0d0
18715       enddo
18716 !C first we calculate the distance from tube center
18717 !C for UNRES
18718        do i=itube_start,itube_end
18719 !C lets ommit dummy atoms for now
18720        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18721 !C now calculate distance from center of tube and direction vectors
18722       xmin=boxxsize
18723       ymin=boxysize
18724 ! Find minimum distance in periodic box
18725         do j=-1,1
18726          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18727          vectube(1)=vectube(1)+boxxsize*j
18728          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18729          vectube(2)=vectube(2)+boxysize*j
18730          xminact=abs(vectube(1)-tubecenter(1))
18731          yminact=abs(vectube(2)-tubecenter(2))
18732            if (xmin.gt.xminact) then
18733             xmin=xminact
18734             xtemp=vectube(1)
18735            endif
18736            if (ymin.gt.yminact) then
18737              ymin=yminact
18738              ytemp=vectube(2)
18739             endif
18740          enddo
18741       vectube(1)=xtemp
18742       vectube(2)=ytemp
18743       vectube(1)=vectube(1)-tubecenter(1)
18744       vectube(2)=vectube(2)-tubecenter(2)
18745
18746 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18747 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18748
18749 !C as the tube is infinity we do not calculate the Z-vector use of Z
18750 !C as chosen axis
18751       vectube(3)=0.0d0
18752 !C now calculte the distance
18753        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18754 !C now normalize vector
18755       vectube(1)=vectube(1)/tub_r
18756       vectube(2)=vectube(2)/tub_r
18757 !C calculte rdiffrence between r and r0
18758       rdiff=tub_r-tubeR0
18759 !C and its 6 power
18760       rdiff6=rdiff**6.0d0
18761 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18762        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18763 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18764 !C       print *,rdiff,rdiff6,pep_aa_tube
18765 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18766 !C now we calculate gradient
18767        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18768             6.0d0*pep_bb_tube)/rdiff6/rdiff
18769 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18770 !C     &rdiff,fac
18771 !C now direction of gg_tube vector
18772         do j=1,3
18773         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18774         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18775         enddo
18776         enddo
18777 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18778 !C        print *,gg_tube(1,0),"TU"
18779
18780
18781        do i=itube_start,itube_end
18782 !C Lets not jump over memory as we use many times iti
18783          iti=itype(i,1)
18784 !C lets ommit dummy atoms for now
18785          if ((iti.eq.ntyp1)  &
18786 !C in UNRES uncomment the line below as GLY has no side-chain...
18787 !C      .or.(iti.eq.10)
18788         ) cycle
18789       xmin=boxxsize
18790       ymin=boxysize
18791         do j=-1,1
18792          vectube(1)=mod((c(1,i+nres)),boxxsize)
18793          vectube(1)=vectube(1)+boxxsize*j
18794          vectube(2)=mod((c(2,i+nres)),boxysize)
18795          vectube(2)=vectube(2)+boxysize*j
18796
18797          xminact=abs(vectube(1)-tubecenter(1))
18798          yminact=abs(vectube(2)-tubecenter(2))
18799            if (xmin.gt.xminact) then
18800             xmin=xminact
18801             xtemp=vectube(1)
18802            endif
18803            if (ymin.gt.yminact) then
18804              ymin=yminact
18805              ytemp=vectube(2)
18806             endif
18807          enddo
18808       vectube(1)=xtemp
18809       vectube(2)=ytemp
18810 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18811 !C     &     tubecenter(2)
18812       vectube(1)=vectube(1)-tubecenter(1)
18813       vectube(2)=vectube(2)-tubecenter(2)
18814
18815 !C as the tube is infinity we do not calculate the Z-vector use of Z
18816 !C as chosen axis
18817       vectube(3)=0.0d0
18818 !C now calculte the distance
18819        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18820 !C now normalize vector
18821       vectube(1)=vectube(1)/tub_r
18822       vectube(2)=vectube(2)/tub_r
18823
18824 !C calculte rdiffrence between r and r0
18825       rdiff=tub_r-tubeR0
18826 !C and its 6 power
18827       rdiff6=rdiff**6.0d0
18828 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18829        sc_aa_tube=sc_aa_tube_par(iti)
18830        sc_bb_tube=sc_bb_tube_par(iti)
18831        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18832        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18833              6.0d0*sc_bb_tube/rdiff6/rdiff
18834 !C now direction of gg_tube vector
18835          do j=1,3
18836           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18837           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18838          enddo
18839         enddo
18840         do i=itube_start,itube_end
18841           Etube=Etube+enetube(i)+enetube(i+nres)
18842         enddo
18843 !C        print *,"ETUBE", etube
18844         return
18845         end subroutine calctube
18846 !C TO DO 1) add to total energy
18847 !C       2) add to gradient summation
18848 !C       3) add reading parameters (AND of course oppening of PARAM file)
18849 !C       4) add reading the center of tube
18850 !C       5) add COMMONs
18851 !C       6) add to zerograd
18852 !C       7) allocate matrices
18853
18854
18855 !C-----------------------------------------------------------------------
18856 !C-----------------------------------------------------------
18857 !C This subroutine is to mimic the histone like structure but as well can be
18858 !C utilizet to nanostructures (infinit) small modification has to be used to
18859 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18860 !C gradient has to be modified at the ends
18861 !C The energy function is Kihara potential
18862 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18863 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18864 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18865 !C simple Kihara potential
18866       subroutine calctube2(Etube)
18867             real(kind=8),dimension(3) :: vectube
18868       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18869        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18870        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18871       integer:: i,j,iti
18872       Etube=0.0d0
18873       do i=itube_start,itube_end
18874         enetube(i)=0.0d0
18875         enetube(i+nres)=0.0d0
18876       enddo
18877 !C first we calculate the distance from tube center
18878 !C first sugare-phosphate group for NARES this would be peptide group
18879 !C for UNRES
18880        do i=itube_start,itube_end
18881 !C lets ommit dummy atoms for now
18882
18883        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18884 !C now calculate distance from center of tube and direction vectors
18885 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18886 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18887 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18888 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18889       xmin=boxxsize
18890       ymin=boxysize
18891         do j=-1,1
18892          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18893          vectube(1)=vectube(1)+boxxsize*j
18894          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18895          vectube(2)=vectube(2)+boxysize*j
18896
18897          xminact=abs(vectube(1)-tubecenter(1))
18898          yminact=abs(vectube(2)-tubecenter(2))
18899            if (xmin.gt.xminact) then
18900             xmin=xminact
18901             xtemp=vectube(1)
18902            endif
18903            if (ymin.gt.yminact) then
18904              ymin=yminact
18905              ytemp=vectube(2)
18906             endif
18907          enddo
18908       vectube(1)=xtemp
18909       vectube(2)=ytemp
18910       vectube(1)=vectube(1)-tubecenter(1)
18911       vectube(2)=vectube(2)-tubecenter(2)
18912
18913 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18914 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18915
18916 !C as the tube is infinity we do not calculate the Z-vector use of Z
18917 !C as chosen axis
18918       vectube(3)=0.0d0
18919 !C now calculte the distance
18920        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18921 !C now normalize vector
18922       vectube(1)=vectube(1)/tub_r
18923       vectube(2)=vectube(2)/tub_r
18924 !C calculte rdiffrence between r and r0
18925       rdiff=tub_r-tubeR0
18926 !C and its 6 power
18927       rdiff6=rdiff**6.0d0
18928 !C THIS FRAGMENT MAKES TUBE FINITE
18929         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18930         if (positi.le.0) positi=positi+boxzsize
18931 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18932 !c for each residue check if it is in lipid or lipid water border area
18933 !C       respos=mod(c(3,i+nres),boxzsize)
18934 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18935        if ((positi.gt.bordtubebot)  &
18936         .and.(positi.lt.bordtubetop)) then
18937 !C the energy transfer exist
18938         if (positi.lt.buftubebot) then
18939          fracinbuf=1.0d0-  &
18940            ((positi-bordtubebot)/tubebufthick)
18941 !C lipbufthick is thickenes of lipid buffore
18942          sstube=sscalelip(fracinbuf)
18943          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18944 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18945          enetube(i)=enetube(i)+sstube*tubetranenepep
18946 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18947 !C     &+ssgradtube*tubetranene(itype(i,1))
18948 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18949 !C     &+ssgradtube*tubetranene(itype(i,1))
18950 !C         print *,"doing sccale for lower part"
18951         elseif (positi.gt.buftubetop) then
18952          fracinbuf=1.0d0-  &
18953         ((bordtubetop-positi)/tubebufthick)
18954          sstube=sscalelip(fracinbuf)
18955          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18956          enetube(i)=enetube(i)+sstube*tubetranenepep
18957 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18958 !C     &+ssgradtube*tubetranene(itype(i,1))
18959 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18960 !C     &+ssgradtube*tubetranene(itype(i,1))
18961 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18962         else
18963          sstube=1.0d0
18964          ssgradtube=0.0d0
18965          enetube(i)=enetube(i)+sstube*tubetranenepep
18966 !C         print *,"I am in true lipid"
18967         endif
18968         else
18969 !C          sstube=0.0d0
18970 !C          ssgradtube=0.0d0
18971         cycle
18972         endif ! if in lipid or buffor
18973
18974 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18975        enetube(i)=enetube(i)+sstube* &
18976         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18977 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18978 !C       print *,rdiff,rdiff6,pep_aa_tube
18979 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18980 !C now we calculate gradient
18981        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18982              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18983 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18984 !C     &rdiff,fac
18985
18986 !C now direction of gg_tube vector
18987        do j=1,3
18988         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18989         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18990         enddo
18991          gg_tube(3,i)=gg_tube(3,i)  &
18992        +ssgradtube*enetube(i)/sstube/2.0d0
18993          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18994        +ssgradtube*enetube(i)/sstube/2.0d0
18995
18996         enddo
18997 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18998 !C        print *,gg_tube(1,0),"TU"
18999         do i=itube_start,itube_end
19000 !C Lets not jump over memory as we use many times iti
19001          iti=itype(i,1)
19002 !C lets ommit dummy atoms for now
19003          if ((iti.eq.ntyp1) &
19004 !!C in UNRES uncomment the line below as GLY has no side-chain...
19005            .or.(iti.eq.10) &
19006           ) cycle
19007           vectube(1)=c(1,i+nres)
19008           vectube(1)=mod(vectube(1),boxxsize)
19009           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19010           vectube(2)=c(2,i+nres)
19011           vectube(2)=mod(vectube(2),boxysize)
19012           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19013
19014       vectube(1)=vectube(1)-tubecenter(1)
19015       vectube(2)=vectube(2)-tubecenter(2)
19016 !C THIS FRAGMENT MAKES TUBE FINITE
19017         positi=(mod(c(3,i+nres),boxzsize))
19018         if (positi.le.0) positi=positi+boxzsize
19019 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19020 !c for each residue check if it is in lipid or lipid water border area
19021 !C       respos=mod(c(3,i+nres),boxzsize)
19022 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19023
19024        if ((positi.gt.bordtubebot)  &
19025         .and.(positi.lt.bordtubetop)) then
19026 !C the energy transfer exist
19027         if (positi.lt.buftubebot) then
19028          fracinbuf=1.0d0- &
19029             ((positi-bordtubebot)/tubebufthick)
19030 !C lipbufthick is thickenes of lipid buffore
19031          sstube=sscalelip(fracinbuf)
19032          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19033 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19034          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19035 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19036 !C     &+ssgradtube*tubetranene(itype(i,1))
19037 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19038 !C     &+ssgradtube*tubetranene(itype(i,1))
19039 !C         print *,"doing sccale for lower part"
19040         elseif (positi.gt.buftubetop) then
19041          fracinbuf=1.0d0- &
19042         ((bordtubetop-positi)/tubebufthick)
19043
19044          sstube=sscalelip(fracinbuf)
19045          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19046          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19047 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19048 !C     &+ssgradtube*tubetranene(itype(i,1))
19049 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19050 !C     &+ssgradtube*tubetranene(itype(i,1))
19051 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19052         else
19053          sstube=1.0d0
19054          ssgradtube=0.0d0
19055          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19056 !C         print *,"I am in true lipid"
19057         endif
19058         else
19059 !C          sstube=0.0d0
19060 !C          ssgradtube=0.0d0
19061         cycle
19062         endif ! if in lipid or buffor
19063 !CEND OF FINITE FRAGMENT
19064 !C as the tube is infinity we do not calculate the Z-vector use of Z
19065 !C as chosen axis
19066       vectube(3)=0.0d0
19067 !C now calculte the distance
19068        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19069 !C now normalize vector
19070       vectube(1)=vectube(1)/tub_r
19071       vectube(2)=vectube(2)/tub_r
19072 !C calculte rdiffrence between r and r0
19073       rdiff=tub_r-tubeR0
19074 !C and its 6 power
19075       rdiff6=rdiff**6.0d0
19076 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19077        sc_aa_tube=sc_aa_tube_par(iti)
19078        sc_bb_tube=sc_bb_tube_par(iti)
19079        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19080                        *sstube+enetube(i+nres)
19081 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19082 !C now we calculate gradient
19083        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19084             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19085 !C now direction of gg_tube vector
19086          do j=1,3
19087           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19088           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19089          enddo
19090          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19091        +ssgradtube*enetube(i+nres)/sstube
19092          gg_tube(3,i-1)= gg_tube(3,i-1) &
19093        +ssgradtube*enetube(i+nres)/sstube
19094
19095         enddo
19096         do i=itube_start,itube_end
19097           Etube=Etube+enetube(i)+enetube(i+nres)
19098         enddo
19099 !C        print *,"ETUBE", etube
19100         return
19101         end subroutine calctube2
19102 !=====================================================================================================================================
19103       subroutine calcnano(Etube)
19104       real(kind=8),dimension(3) :: vectube
19105
19106       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19107        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19108        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19109        integer:: i,j,iti,r
19110
19111       Etube=0.0d0
19112 !      print *,itube_start,itube_end,"poczatek"
19113       do i=itube_start,itube_end
19114         enetube(i)=0.0d0
19115         enetube(i+nres)=0.0d0
19116       enddo
19117 !C first we calculate the distance from tube center
19118 !C first sugare-phosphate group for NARES this would be peptide group
19119 !C for UNRES
19120        do i=itube_start,itube_end
19121 !C lets ommit dummy atoms for now
19122        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19123 !C now calculate distance from center of tube and direction vectors
19124       xmin=boxxsize
19125       ymin=boxysize
19126       zmin=boxzsize
19127
19128         do j=-1,1
19129          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19130          vectube(1)=vectube(1)+boxxsize*j
19131          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19132          vectube(2)=vectube(2)+boxysize*j
19133          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19134          vectube(3)=vectube(3)+boxzsize*j
19135
19136
19137          xminact=dabs(vectube(1)-tubecenter(1))
19138          yminact=dabs(vectube(2)-tubecenter(2))
19139          zminact=dabs(vectube(3)-tubecenter(3))
19140
19141            if (xmin.gt.xminact) then
19142             xmin=xminact
19143             xtemp=vectube(1)
19144            endif
19145            if (ymin.gt.yminact) then
19146              ymin=yminact
19147              ytemp=vectube(2)
19148             endif
19149            if (zmin.gt.zminact) then
19150              zmin=zminact
19151              ztemp=vectube(3)
19152             endif
19153          enddo
19154       vectube(1)=xtemp
19155       vectube(2)=ytemp
19156       vectube(3)=ztemp
19157
19158       vectube(1)=vectube(1)-tubecenter(1)
19159       vectube(2)=vectube(2)-tubecenter(2)
19160       vectube(3)=vectube(3)-tubecenter(3)
19161
19162 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19163 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19164 !C as the tube is infinity we do not calculate the Z-vector use of Z
19165 !C as chosen axis
19166 !C      vectube(3)=0.0d0
19167 !C now calculte the distance
19168        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19169 !C now normalize vector
19170       vectube(1)=vectube(1)/tub_r
19171       vectube(2)=vectube(2)/tub_r
19172       vectube(3)=vectube(3)/tub_r
19173 !C calculte rdiffrence between r and r0
19174       rdiff=tub_r-tubeR0
19175 !C and its 6 power
19176       rdiff6=rdiff**6.0d0
19177 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19178        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19179 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19180 !C       print *,rdiff,rdiff6,pep_aa_tube
19181 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19182 !C now we calculate gradient
19183        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19184             6.0d0*pep_bb_tube)/rdiff6/rdiff
19185 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19186 !C     &rdiff,fac
19187          if (acavtubpep.eq.0.0d0) then
19188 !C go to 667
19189          enecavtube(i)=0.0
19190          faccav=0.0
19191          else
19192          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19193          enecavtube(i)=  &
19194         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19195         /denominator
19196          enecavtube(i)=0.0
19197          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19198         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19199         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19200         /denominator**2.0d0
19201 !C         faccav=0.0
19202 !C         fac=fac+faccav
19203 !C 667     continue
19204          endif
19205           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19206         do j=1,3
19207         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19208         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19209         enddo
19210         enddo
19211
19212        do i=itube_start,itube_end
19213         enecavtube(i)=0.0d0
19214 !C Lets not jump over memory as we use many times iti
19215          iti=itype(i,1)
19216 !C lets ommit dummy atoms for now
19217          if ((iti.eq.ntyp1) &
19218 !C in UNRES uncomment the line below as GLY has no side-chain...
19219 !C      .or.(iti.eq.10)
19220          ) cycle
19221       xmin=boxxsize
19222       ymin=boxysize
19223       zmin=boxzsize
19224         do j=-1,1
19225          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19226          vectube(1)=vectube(1)+boxxsize*j
19227          vectube(2)=dmod((c(2,i+nres)),boxysize)
19228          vectube(2)=vectube(2)+boxysize*j
19229          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19230          vectube(3)=vectube(3)+boxzsize*j
19231
19232
19233          xminact=dabs(vectube(1)-tubecenter(1))
19234          yminact=dabs(vectube(2)-tubecenter(2))
19235          zminact=dabs(vectube(3)-tubecenter(3))
19236
19237            if (xmin.gt.xminact) then
19238             xmin=xminact
19239             xtemp=vectube(1)
19240            endif
19241            if (ymin.gt.yminact) then
19242              ymin=yminact
19243              ytemp=vectube(2)
19244             endif
19245            if (zmin.gt.zminact) then
19246              zmin=zminact
19247              ztemp=vectube(3)
19248             endif
19249          enddo
19250       vectube(1)=xtemp
19251       vectube(2)=ytemp
19252       vectube(3)=ztemp
19253
19254 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19255 !C     &     tubecenter(2)
19256       vectube(1)=vectube(1)-tubecenter(1)
19257       vectube(2)=vectube(2)-tubecenter(2)
19258       vectube(3)=vectube(3)-tubecenter(3)
19259 !C now calculte the distance
19260        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19261 !C now normalize vector
19262       vectube(1)=vectube(1)/tub_r
19263       vectube(2)=vectube(2)/tub_r
19264       vectube(3)=vectube(3)/tub_r
19265
19266 !C calculte rdiffrence between r and r0
19267       rdiff=tub_r-tubeR0
19268 !C and its 6 power
19269       rdiff6=rdiff**6.0d0
19270        sc_aa_tube=sc_aa_tube_par(iti)
19271        sc_bb_tube=sc_bb_tube_par(iti)
19272        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19273 !C       enetube(i+nres)=0.0d0
19274 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19275 !C now we calculate gradient
19276        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19277             6.0d0*sc_bb_tube/rdiff6/rdiff
19278 !C       fac=0.0
19279 !C now direction of gg_tube vector
19280 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19281          if (acavtub(iti).eq.0.0d0) then
19282 !C go to 667
19283          enecavtube(i+nres)=0.0d0
19284          faccav=0.0d0
19285          else
19286          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19287          enecavtube(i+nres)=   &
19288         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19289         /denominator
19290 !C         enecavtube(i)=0.0
19291          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19292         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19293         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19294         /denominator**2.0d0
19295 !C         faccav=0.0
19296          fac=fac+faccav
19297 !C 667     continue
19298          endif
19299 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19300 !C     &   enecavtube(i),faccav
19301 !C         print *,"licz=",
19302 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19303 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19304          do j=1,3
19305           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19306           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19307          enddo
19308           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19309         enddo
19310
19311
19312
19313         do i=itube_start,itube_end
19314           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19315          +enecavtube(i+nres)
19316         enddo
19317 !        do i=1,20
19318 !         print *,"begin", i,"a"
19319 !         do r=1,10000
19320 !          rdiff=r/100.0d0
19321 !          rdiff6=rdiff**6.0d0
19322 !          sc_aa_tube=sc_aa_tube_par(i)
19323 !          sc_bb_tube=sc_bb_tube_par(i)
19324 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19325 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19326 !          enecavtube(i)=   &
19327 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19328 !         /denominator
19329
19330 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19331 !         enddo
19332 !         print *,"end",i,"a"
19333 !        enddo
19334 !C        print *,"ETUBE", etube
19335         return
19336         end subroutine calcnano
19337
19338 !===============================================
19339 !--------------------------------------------------------------------------------
19340 !C first for shielding is setting of function of side-chains
19341
19342        subroutine set_shield_fac2
19343        real(kind=8) :: div77_81=0.974996043d0, &
19344         div4_81=0.2222222222d0
19345        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19346          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19347          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19348          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19349 !C the vector between center of side_chain and peptide group
19350        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19351          pept_group,costhet_grad,cosphi_grad_long, &
19352          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19353          sh_frac_dist_grad,pep_side
19354         integer i,j,k
19355 !C      write(2,*) "ivec",ivec_start,ivec_end
19356       do i=1,nres
19357         fac_shield(i)=0.0d0
19358         do j=1,3
19359         grad_shield(j,i)=0.0d0
19360         enddo
19361       enddo
19362       do i=ivec_start,ivec_end
19363 !C      do i=1,nres-1
19364 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19365       ishield_list(i)=0
19366       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19367 !Cif there two consequtive dummy atoms there is no peptide group between them
19368 !C the line below has to be changed for FGPROC>1
19369       VolumeTotal=0.0
19370       do k=1,nres
19371        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19372        dist_pep_side=0.0
19373        dist_side_calf=0.0
19374        do j=1,3
19375 !C first lets set vector conecting the ithe side-chain with kth side-chain
19376       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19377 !C      pep_side(j)=2.0d0
19378 !C and vector conecting the side-chain with its proper calfa
19379       side_calf(j)=c(j,k+nres)-c(j,k)
19380 !C      side_calf(j)=2.0d0
19381       pept_group(j)=c(j,i)-c(j,i+1)
19382 !C lets have their lenght
19383       dist_pep_side=pep_side(j)**2+dist_pep_side
19384       dist_side_calf=dist_side_calf+side_calf(j)**2
19385       dist_pept_group=dist_pept_group+pept_group(j)**2
19386       enddo
19387        dist_pep_side=sqrt(dist_pep_side)
19388        dist_pept_group=sqrt(dist_pept_group)
19389        dist_side_calf=sqrt(dist_side_calf)
19390       do j=1,3
19391         pep_side_norm(j)=pep_side(j)/dist_pep_side
19392         side_calf_norm(j)=dist_side_calf
19393       enddo
19394 !C now sscale fraction
19395        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19396 !C       print *,buff_shield,"buff"
19397 !C now sscale
19398         if (sh_frac_dist.le.0.0) cycle
19399 !C        print *,ishield_list(i),i
19400 !C If we reach here it means that this side chain reaches the shielding sphere
19401 !C Lets add him to the list for gradient
19402         ishield_list(i)=ishield_list(i)+1
19403 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19404 !C this list is essential otherwise problem would be O3
19405         shield_list(ishield_list(i),i)=k
19406 !C Lets have the sscale value
19407         if (sh_frac_dist.gt.1.0) then
19408          scale_fac_dist=1.0d0
19409          do j=1,3
19410          sh_frac_dist_grad(j)=0.0d0
19411          enddo
19412         else
19413          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19414                         *(2.0d0*sh_frac_dist-3.0d0)
19415          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19416                        /dist_pep_side/buff_shield*0.5d0
19417          do j=1,3
19418          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19419 !C         sh_frac_dist_grad(j)=0.0d0
19420 !C         scale_fac_dist=1.0d0
19421 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19422 !C     &                    sh_frac_dist_grad(j)
19423          enddo
19424         endif
19425 !C this is what is now we have the distance scaling now volume...
19426       short=short_r_sidechain(itype(k,1))
19427       long=long_r_sidechain(itype(k,1))
19428       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19429       sinthet=short/dist_pep_side*costhet
19430 !C now costhet_grad
19431 !C       costhet=0.6d0
19432 !C       sinthet=0.8
19433        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19434 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19435 !C     &             -short/dist_pep_side**2/costhet)
19436 !C       costhet_fac=0.0d0
19437        do j=1,3
19438          costhet_grad(j)=costhet_fac*pep_side(j)
19439        enddo
19440 !C remember for the final gradient multiply costhet_grad(j)
19441 !C for side_chain by factor -2 !
19442 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19443 !C pep_side0pept_group is vector multiplication
19444       pep_side0pept_group=0.0d0
19445       do j=1,3
19446       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19447       enddo
19448       cosalfa=(pep_side0pept_group/ &
19449       (dist_pep_side*dist_side_calf))
19450       fac_alfa_sin=1.0d0-cosalfa**2
19451       fac_alfa_sin=dsqrt(fac_alfa_sin)
19452       rkprim=fac_alfa_sin*(long-short)+short
19453 !C      rkprim=short
19454
19455 !C now costhet_grad
19456        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19457 !C       cosphi=0.6
19458        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19459        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19460            dist_pep_side**2)
19461 !C       sinphi=0.8
19462        do j=1,3
19463          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19464       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19465       *(long-short)/fac_alfa_sin*cosalfa/ &
19466       ((dist_pep_side*dist_side_calf))* &
19467       ((side_calf(j))-cosalfa* &
19468       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19469 !C       cosphi_grad_long(j)=0.0d0
19470         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19471       *(long-short)/fac_alfa_sin*cosalfa &
19472       /((dist_pep_side*dist_side_calf))* &
19473       (pep_side(j)- &
19474       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19475 !C       cosphi_grad_loc(j)=0.0d0
19476        enddo
19477 !C      print *,sinphi,sinthet
19478       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19479      &                    /VSolvSphere_div
19480 !C     &                    *wshield
19481 !C now the gradient...
19482       do j=1,3
19483       grad_shield(j,i)=grad_shield(j,i) &
19484 !C gradient po skalowaniu
19485                      +(sh_frac_dist_grad(j)*VofOverlap &
19486 !C  gradient po costhet
19487             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19488         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19489             sinphi/sinthet*costhet*costhet_grad(j) &
19490            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19491         )*wshield
19492 !C grad_shield_side is Cbeta sidechain gradient
19493       grad_shield_side(j,ishield_list(i),i)=&
19494              (sh_frac_dist_grad(j)*-2.0d0&
19495              *VofOverlap&
19496             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19497        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19498             sinphi/sinthet*costhet*costhet_grad(j)&
19499            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19500             )*wshield
19501
19502        grad_shield_loc(j,ishield_list(i),i)=   &
19503             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19504       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19505             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19506              ))&
19507              *wshield
19508       enddo
19509       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19510       enddo
19511       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19512
19513 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19514       enddo
19515       return
19516       end subroutine set_shield_fac2
19517 !----------------------------------------------------------------------------
19518 ! SOUBROUTINE FOR AFM
19519        subroutine AFMvel(Eafmforce)
19520        use MD_data, only:totTafm
19521       real(kind=8),dimension(3) :: diffafm
19522       real(kind=8) :: afmdist,Eafmforce
19523        integer :: i
19524 !C Only for check grad COMMENT if not used for checkgrad
19525 !C      totT=3.0d0
19526 !C--------------------------------------------------------
19527 !C      print *,"wchodze"
19528       afmdist=0.0d0
19529       Eafmforce=0.0d0
19530       do i=1,3
19531       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19532       afmdist=afmdist+diffafm(i)**2
19533       enddo
19534       afmdist=dsqrt(afmdist)
19535 !      totTafm=3.0
19536       Eafmforce=0.5d0*forceAFMconst &
19537       *(distafminit+totTafm*velAFMconst-afmdist)**2
19538 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19539       do i=1,3
19540       gradafm(i,afmend-1)=-forceAFMconst* &
19541        (distafminit+totTafm*velAFMconst-afmdist) &
19542        *diffafm(i)/afmdist
19543       gradafm(i,afmbeg-1)=forceAFMconst* &
19544       (distafminit+totTafm*velAFMconst-afmdist) &
19545       *diffafm(i)/afmdist
19546       enddo
19547 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19548       return
19549       end subroutine AFMvel
19550 !---------------------------------------------------------
19551        subroutine AFMforce(Eafmforce)
19552
19553       real(kind=8),dimension(3) :: diffafm
19554 !      real(kind=8) ::afmdist
19555       real(kind=8) :: afmdist,Eafmforce
19556       integer :: i
19557       afmdist=0.0d0
19558       Eafmforce=0.0d0
19559       do i=1,3
19560       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19561       afmdist=afmdist+diffafm(i)**2
19562       enddo
19563       afmdist=dsqrt(afmdist)
19564 !      print *,afmdist,distafminit
19565       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19566       do i=1,3
19567       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19568       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19569       enddo
19570 !C      print *,'AFM',Eafmforce
19571       return
19572       end subroutine AFMforce
19573
19574 !-----------------------------------------------------------------------------
19575 #ifdef WHAM
19576       subroutine read_ssHist
19577 !      implicit none
19578 !      Includes
19579 !      include 'DIMENSIONS'
19580 !      include "DIMENSIONS.FREE"
19581 !      include 'COMMON.FREE'
19582 !     Local variables
19583       integer :: i,j
19584       character(len=80) :: controlcard
19585
19586       do i=1,dyn_nssHist
19587         call card_concat(controlcard,.true.)
19588         read(controlcard,*) &
19589              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19590       enddo
19591
19592       return
19593       end subroutine read_ssHist
19594 #endif
19595 !-----------------------------------------------------------------------------
19596       integer function indmat(i,j)
19597 !el
19598 ! get the position of the jth ijth fragment of the chain coordinate system
19599 ! in the fromto array.
19600         integer :: i,j
19601
19602         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19603       return
19604       end function indmat
19605 !-----------------------------------------------------------------------------
19606       real(kind=8) function sigm(x)
19607 !el
19608        real(kind=8) :: x
19609         sigm=0.25d0*x
19610       return
19611       end function sigm
19612 !-----------------------------------------------------------------------------
19613 !-----------------------------------------------------------------------------
19614       subroutine alloc_ener_arrays
19615 !EL Allocation of arrays used by module energy
19616       use MD_data, only: mset
19617 !el local variables
19618       integer :: i,j
19619
19620       if(nres.lt.100) then
19621         maxconts=nres
19622       elseif(nres.lt.200) then
19623         maxconts=0.8*nres      ! Max. number of contacts per residue
19624       else
19625         maxconts=0.6*nres ! (maxconts=maxres/4)
19626       endif
19627       maxcont=12*nres      ! Max. number of SC contacts
19628       maxvar=6*nres      ! Max. number of variables
19629 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19630       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19631 !----------------------
19632 ! arrays in subroutine init_int_table
19633 !el#ifdef MPI
19634 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19635 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19636 !el#endif
19637       allocate(nint_gr(nres))
19638       allocate(nscp_gr(nres))
19639       allocate(ielstart(nres))
19640       allocate(ielend(nres))
19641 !(maxres)
19642       allocate(istart(nres,maxint_gr))
19643       allocate(iend(nres,maxint_gr))
19644 !(maxres,maxint_gr)
19645       allocate(iscpstart(nres,maxint_gr))
19646       allocate(iscpend(nres,maxint_gr))
19647 !(maxres,maxint_gr)
19648       allocate(ielstart_vdw(nres))
19649       allocate(ielend_vdw(nres))
19650 !(maxres)
19651       allocate(nint_gr_nucl(nres))
19652       allocate(nscp_gr_nucl(nres))
19653       allocate(ielstart_nucl(nres))
19654       allocate(ielend_nucl(nres))
19655 !(maxres)
19656       allocate(istart_nucl(nres,maxint_gr))
19657       allocate(iend_nucl(nres,maxint_gr))
19658 !(maxres,maxint_gr)
19659       allocate(iscpstart_nucl(nres,maxint_gr))
19660       allocate(iscpend_nucl(nres,maxint_gr))
19661 !(maxres,maxint_gr)
19662       allocate(ielstart_vdw_nucl(nres))
19663       allocate(ielend_vdw_nucl(nres))
19664
19665       allocate(lentyp(0:nfgtasks-1))
19666 !(0:maxprocs-1)
19667 !----------------------
19668 ! commom.contacts
19669 !      common /contacts/
19670       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19671       allocate(icont(2,maxcont))
19672 !(2,maxcont)
19673 !      common /contacts1/
19674       allocate(num_cont(0:nres+4))
19675 !(maxres)
19676       allocate(jcont(maxconts,nres))
19677 !(maxconts,maxres)
19678       allocate(facont(maxconts,nres))
19679 !(maxconts,maxres)
19680       allocate(gacont(3,maxconts,nres))
19681 !(3,maxconts,maxres)
19682 !      common /contacts_hb/
19683       allocate(gacontp_hb1(3,maxconts,nres))
19684       allocate(gacontp_hb2(3,maxconts,nres))
19685       allocate(gacontp_hb3(3,maxconts,nres))
19686       allocate(gacontm_hb1(3,maxconts,nres))
19687       allocate(gacontm_hb2(3,maxconts,nres))
19688       allocate(gacontm_hb3(3,maxconts,nres))
19689       allocate(gacont_hbr(3,maxconts,nres))
19690       allocate(grij_hb_cont(3,maxconts,nres))
19691 !(3,maxconts,maxres)
19692       allocate(facont_hb(maxconts,nres))
19693
19694       allocate(ees0p(maxconts,nres))
19695       allocate(ees0m(maxconts,nres))
19696       allocate(d_cont(maxconts,nres))
19697       allocate(ees0plist(maxconts,nres))
19698
19699 !(maxconts,maxres)
19700       allocate(num_cont_hb(nres))
19701 !(maxres)
19702       allocate(jcont_hb(maxconts,nres))
19703 !(maxconts,maxres)
19704 !      common /rotat/
19705       allocate(Ug(2,2,nres))
19706       allocate(Ugder(2,2,nres))
19707       allocate(Ug2(2,2,nres))
19708       allocate(Ug2der(2,2,nres))
19709 !(2,2,maxres)
19710       allocate(obrot(2,nres))
19711       allocate(obrot2(2,nres))
19712       allocate(obrot_der(2,nres))
19713       allocate(obrot2_der(2,nres))
19714 !(2,maxres)
19715 !      common /precomp1/
19716       allocate(mu(2,nres))
19717       allocate(muder(2,nres))
19718       allocate(Ub2(2,nres))
19719       Ub2(1,:)=0.0d0
19720       Ub2(2,:)=0.0d0
19721       allocate(Ub2der(2,nres))
19722       allocate(Ctobr(2,nres))
19723       allocate(Ctobrder(2,nres))
19724       allocate(Dtobr2(2,nres))
19725       allocate(Dtobr2der(2,nres))
19726 !(2,maxres)
19727       allocate(EUg(2,2,nres))
19728       allocate(EUgder(2,2,nres))
19729       allocate(CUg(2,2,nres))
19730       allocate(CUgder(2,2,nres))
19731       allocate(DUg(2,2,nres))
19732       allocate(Dugder(2,2,nres))
19733       allocate(DtUg2(2,2,nres))
19734       allocate(DtUg2der(2,2,nres))
19735 !(2,2,maxres)
19736 !      common /precomp2/
19737       allocate(Ug2Db1t(2,nres))
19738       allocate(Ug2Db1tder(2,nres))
19739       allocate(CUgb2(2,nres))
19740       allocate(CUgb2der(2,nres))
19741 !(2,maxres)
19742       allocate(EUgC(2,2,nres))
19743       allocate(EUgCder(2,2,nres))
19744       allocate(EUgD(2,2,nres))
19745       allocate(EUgDder(2,2,nres))
19746       allocate(DtUg2EUg(2,2,nres))
19747       allocate(Ug2DtEUg(2,2,nres))
19748 !(2,2,maxres)
19749       allocate(Ug2DtEUgder(2,2,2,nres))
19750       allocate(DtUg2EUgder(2,2,2,nres))
19751 !(2,2,2,maxres)
19752 !      common /rotat_old/
19753       allocate(costab(nres))
19754       allocate(sintab(nres))
19755       allocate(costab2(nres))
19756       allocate(sintab2(nres))
19757 !(maxres)
19758 !      common /dipmat/
19759       allocate(a_chuj(2,2,maxconts,nres))
19760 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19761       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19762 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19763 !      common /contdistrib/
19764       allocate(ncont_sent(nres))
19765       allocate(ncont_recv(nres))
19766
19767       allocate(iat_sent(nres))
19768 !(maxres)
19769       allocate(iint_sent(4,nres,nres))
19770       allocate(iint_sent_local(4,nres,nres))
19771 !(4,maxres,maxres)
19772       allocate(iturn3_sent(4,0:nres+4))
19773       allocate(iturn4_sent(4,0:nres+4))
19774       allocate(iturn3_sent_local(4,nres))
19775       allocate(iturn4_sent_local(4,nres))
19776 !(4,maxres)
19777       allocate(itask_cont_from(0:nfgtasks-1))
19778       allocate(itask_cont_to(0:nfgtasks-1))
19779 !(0:max_fg_procs-1)
19780
19781
19782
19783 !----------------------
19784 ! commom.deriv;
19785 !      common /derivat/
19786       allocate(dcdv(6,maxdim))
19787       allocate(dxdv(6,maxdim))
19788 !(6,maxdim)
19789       allocate(dxds(6,nres))
19790 !(6,maxres)
19791       allocate(gradx(3,-1:nres,0:2))
19792       allocate(gradc(3,-1:nres,0:2))
19793 !(3,maxres,2)
19794       allocate(gvdwx(3,-1:nres))
19795       allocate(gvdwc(3,-1:nres))
19796       allocate(gelc(3,-1:nres))
19797       allocate(gelc_long(3,-1:nres))
19798       allocate(gvdwpp(3,-1:nres))
19799       allocate(gvdwc_scpp(3,-1:nres))
19800       allocate(gradx_scp(3,-1:nres))
19801       allocate(gvdwc_scp(3,-1:nres))
19802       allocate(ghpbx(3,-1:nres))
19803       allocate(ghpbc(3,-1:nres))
19804       allocate(gradcorr(3,-1:nres))
19805       allocate(gradcorr_long(3,-1:nres))
19806       allocate(gradcorr5_long(3,-1:nres))
19807       allocate(gradcorr6_long(3,-1:nres))
19808       allocate(gcorr6_turn_long(3,-1:nres))
19809       allocate(gradxorr(3,-1:nres))
19810       allocate(gradcorr5(3,-1:nres))
19811       allocate(gradcorr6(3,-1:nres))
19812       allocate(gliptran(3,-1:nres))
19813       allocate(gliptranc(3,-1:nres))
19814       allocate(gliptranx(3,-1:nres))
19815       allocate(gshieldx(3,-1:nres))
19816       allocate(gshieldc(3,-1:nres))
19817       allocate(gshieldc_loc(3,-1:nres))
19818       allocate(gshieldx_ec(3,-1:nres))
19819       allocate(gshieldc_ec(3,-1:nres))
19820       allocate(gshieldc_loc_ec(3,-1:nres))
19821       allocate(gshieldx_t3(3,-1:nres))
19822       allocate(gshieldc_t3(3,-1:nres))
19823       allocate(gshieldc_loc_t3(3,-1:nres))
19824       allocate(gshieldx_t4(3,-1:nres))
19825       allocate(gshieldc_t4(3,-1:nres))
19826       allocate(gshieldc_loc_t4(3,-1:nres))
19827       allocate(gshieldx_ll(3,-1:nres))
19828       allocate(gshieldc_ll(3,-1:nres))
19829       allocate(gshieldc_loc_ll(3,-1:nres))
19830       allocate(grad_shield(3,-1:nres))
19831       allocate(gg_tube_sc(3,-1:nres))
19832       allocate(gg_tube(3,-1:nres))
19833       allocate(gradafm(3,-1:nres))
19834       allocate(gradb_nucl(3,-1:nres))
19835       allocate(gradbx_nucl(3,-1:nres))
19836       allocate(gvdwpsb1(3,-1:nres))
19837       allocate(gelpp(3,-1:nres))
19838       allocate(gvdwpsb(3,-1:nres))
19839       allocate(gelsbc(3,-1:nres))
19840       allocate(gelsbx(3,-1:nres))
19841       allocate(gvdwsbx(3,-1:nres))
19842       allocate(gvdwsbc(3,-1:nres))
19843       allocate(gsbloc(3,-1:nres))
19844       allocate(gsblocx(3,-1:nres))
19845       allocate(gradcorr_nucl(3,-1:nres))
19846       allocate(gradxorr_nucl(3,-1:nres))
19847       allocate(gradcorr3_nucl(3,-1:nres))
19848       allocate(gradxorr3_nucl(3,-1:nres))
19849       allocate(gvdwpp_nucl(3,-1:nres))
19850       allocate(gradpepcat(3,-1:nres))
19851       allocate(gradpepcatx(3,-1:nres))
19852       allocate(gradcatcat(3,-1:nres))
19853 !(3,maxres)
19854       allocate(grad_shield_side(3,50,nres))
19855       allocate(grad_shield_loc(3,50,nres))
19856 ! grad for shielding surroing
19857       allocate(gloc(0:maxvar,0:2))
19858       allocate(gloc_x(0:maxvar,2))
19859 !(maxvar,2)
19860       allocate(gel_loc(3,-1:nres))
19861       allocate(gel_loc_long(3,-1:nres))
19862       allocate(gcorr3_turn(3,-1:nres))
19863       allocate(gcorr4_turn(3,-1:nres))
19864       allocate(gcorr6_turn(3,-1:nres))
19865       allocate(gradb(3,-1:nres))
19866       allocate(gradbx(3,-1:nres))
19867 !(3,maxres)
19868       allocate(gel_loc_loc(maxvar))
19869       allocate(gel_loc_turn3(maxvar))
19870       allocate(gel_loc_turn4(maxvar))
19871       allocate(gel_loc_turn6(maxvar))
19872       allocate(gcorr_loc(maxvar))
19873       allocate(g_corr5_loc(maxvar))
19874       allocate(g_corr6_loc(maxvar))
19875 !(maxvar)
19876       allocate(gsccorc(3,-1:nres))
19877       allocate(gsccorx(3,-1:nres))
19878 !(3,maxres)
19879       allocate(gsccor_loc(-1:nres))
19880 !(maxres)
19881       allocate(gvdwx_scbase(3,-1:nres))
19882       allocate(gvdwc_scbase(3,-1:nres))
19883       allocate(gvdwx_pepbase(3,-1:nres))
19884       allocate(gvdwc_pepbase(3,-1:nres))
19885       allocate(gvdwx_scpho(3,-1:nres))
19886       allocate(gvdwc_scpho(3,-1:nres))
19887       allocate(gvdwc_peppho(3,-1:nres))
19888
19889       allocate(dtheta(3,2,-1:nres))
19890 !(3,2,maxres)
19891       allocate(gscloc(3,-1:nres))
19892       allocate(gsclocx(3,-1:nres))
19893 !(3,maxres)
19894       allocate(dphi(3,3,-1:nres))
19895       allocate(dalpha(3,3,-1:nres))
19896       allocate(domega(3,3,-1:nres))
19897 !(3,3,maxres)
19898 !      common /deriv_scloc/
19899       allocate(dXX_C1tab(3,nres))
19900       allocate(dYY_C1tab(3,nres))
19901       allocate(dZZ_C1tab(3,nres))
19902       allocate(dXX_Ctab(3,nres))
19903       allocate(dYY_Ctab(3,nres))
19904       allocate(dZZ_Ctab(3,nres))
19905       allocate(dXX_XYZtab(3,nres))
19906       allocate(dYY_XYZtab(3,nres))
19907       allocate(dZZ_XYZtab(3,nres))
19908 !(3,maxres)
19909 !      common /mpgrad/
19910       allocate(jgrad_start(nres))
19911       allocate(jgrad_end(nres))
19912 !(maxres)
19913 !----------------------
19914
19915 !      common /indices/
19916       allocate(ibond_displ(0:nfgtasks-1))
19917       allocate(ibond_count(0:nfgtasks-1))
19918       allocate(ithet_displ(0:nfgtasks-1))
19919       allocate(ithet_count(0:nfgtasks-1))
19920       allocate(iphi_displ(0:nfgtasks-1))
19921       allocate(iphi_count(0:nfgtasks-1))
19922       allocate(iphi1_displ(0:nfgtasks-1))
19923       allocate(iphi1_count(0:nfgtasks-1))
19924       allocate(ivec_displ(0:nfgtasks-1))
19925       allocate(ivec_count(0:nfgtasks-1))
19926       allocate(iset_displ(0:nfgtasks-1))
19927       allocate(iset_count(0:nfgtasks-1))
19928       allocate(iint_count(0:nfgtasks-1))
19929       allocate(iint_displ(0:nfgtasks-1))
19930 !(0:max_fg_procs-1)
19931 !----------------------
19932 ! common.MD
19933 !      common /mdgrad/
19934       allocate(gcart(3,-1:nres))
19935       allocate(gxcart(3,-1:nres))
19936 !(3,0:MAXRES)
19937       allocate(gradcag(3,-1:nres))
19938       allocate(gradxag(3,-1:nres))
19939 !(3,MAXRES)
19940 !      common /back_constr/
19941 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19942       allocate(dutheta(nres))
19943       allocate(dugamma(nres))
19944 !(maxres)
19945       allocate(duscdiff(3,nres))
19946       allocate(duscdiffx(3,nres))
19947 !(3,maxres)
19948 !el i io:read_fragments
19949 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19950 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19951 !      common /qmeas/
19952 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19953 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19954       allocate(mset(0:nprocs))  !(maxprocs/20)
19955       mset(:)=0
19956 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19957 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19958       allocate(dUdconst(3,0:nres))
19959       allocate(dUdxconst(3,0:nres))
19960       allocate(dqwol(3,0:nres))
19961       allocate(dxqwol(3,0:nres))
19962 !(3,0:MAXRES)
19963 !----------------------
19964 ! common.sbridge
19965 !      common /sbridge/ in io_common: read_bridge
19966 !el    allocate((:),allocatable :: iss      !(maxss)
19967 !      common /links/  in io_common: read_bridge
19968 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19969 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19970 !      common /dyn_ssbond/
19971 ! and side-chain vectors in theta or phi.
19972       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19973 !(maxres,maxres)
19974 !      do i=1,nres
19975 !        do j=i+1,nres
19976       dyn_ssbond_ij(:,:)=1.0d300
19977 !        enddo
19978 !      enddo
19979
19980 !      if (nss.gt.0) then
19981         allocate(idssb(maxdim),jdssb(maxdim))
19982 !        allocate(newihpb(nss),newjhpb(nss))
19983 !(maxdim)
19984 !      endif
19985       allocate(ishield_list(nres))
19986       allocate(shield_list(50,nres))
19987       allocate(dyn_ss_mask(nres))
19988       allocate(fac_shield(nres))
19989       allocate(enetube(nres*2))
19990       allocate(enecavtube(nres*2))
19991
19992 !(maxres)
19993       dyn_ss_mask(:)=.false.
19994 !----------------------
19995 ! common.sccor
19996 ! Parameters of the SCCOR term
19997 !      common/sccor/
19998 !el in io_conf: parmread
19999 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20000 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20001 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20002 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20003 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20004 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20005 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20006 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20007 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20008 !----------------
20009       allocate(gloc_sc(3,0:2*nres,0:10))
20010 !(3,0:maxres2,10)maxres2=2*maxres
20011       allocate(dcostau(3,3,3,2*nres))
20012       allocate(dsintau(3,3,3,2*nres))
20013       allocate(dtauangle(3,3,3,2*nres))
20014       allocate(dcosomicron(3,3,3,2*nres))
20015       allocate(domicron(3,3,3,2*nres))
20016 !(3,3,3,maxres2)maxres2=2*maxres
20017 !----------------------
20018 ! common.var
20019 !      common /restr/
20020       allocate(varall(maxvar))
20021 !(maxvar)(maxvar=6*maxres)
20022       allocate(mask_theta(nres))
20023       allocate(mask_phi(nres))
20024       allocate(mask_side(nres))
20025 !(maxres)
20026 !----------------------
20027 ! common.vectors
20028 !      common /vectors/
20029       allocate(uy(3,nres))
20030       allocate(uz(3,nres))
20031 !(3,maxres)
20032       allocate(uygrad(3,3,2,nres))
20033       allocate(uzgrad(3,3,2,nres))
20034 !(3,3,2,maxres)
20035
20036       return
20037       end subroutine alloc_ener_arrays
20038 !-----------------------------------------------------------------
20039       subroutine ebond_nucl(estr_nucl)
20040 !c
20041 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20042 !c
20043
20044       real(kind=8),dimension(3) :: u,ud
20045       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20046       real(kind=8) :: estr_nucl,diff
20047       integer :: iti,i,j,k,nbi
20048       estr_nucl=0.0d0
20049 !C      print *,"I enter ebond"
20050       if (energy_dec) &
20051       write (iout,*) "ibondp_start,ibondp_end",&
20052        ibondp_nucl_start,ibondp_nucl_end
20053       do i=ibondp_nucl_start,ibondp_nucl_end
20054         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20055          itype(i,2).eq.ntyp1_molec(2)) cycle
20056 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20057 !          do j=1,3
20058 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20059 !     &      *dc(j,i-1)/vbld(i)
20060 !          enddo
20061 !          if (energy_dec) write(iout,*)
20062 !     &       "estr1",i,vbld(i),distchainmax,
20063 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20064
20065           diff = vbld(i)-vbldp0_nucl
20066           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20067           vbldp0_nucl,diff,AKP_nucl*diff*diff
20068           estr_nucl=estr_nucl+diff*diff
20069 !          print *,estr_nucl
20070           do j=1,3
20071             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20072           enddo
20073 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20074       enddo
20075       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20076 !      print *,"partial sum", estr_nucl,AKP_nucl
20077
20078       if (energy_dec) &
20079       write (iout,*) "ibondp_start,ibondp_end",&
20080        ibond_nucl_start,ibond_nucl_end
20081
20082       do i=ibond_nucl_start,ibond_nucl_end
20083 !C        print *, "I am stuck",i
20084         iti=itype(i,2)
20085         if (iti.eq.ntyp1_molec(2)) cycle
20086           nbi=nbondterm_nucl(iti)
20087 !C        print *,iti,nbi
20088           if (nbi.eq.1) then
20089             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20090
20091             if (energy_dec) &
20092            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20093            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20094             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20095 !            print *,estr_nucl
20096             do j=1,3
20097               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20098             enddo
20099           else
20100             do j=1,nbi
20101               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20102               ud(j)=aksc_nucl(j,iti)*diff
20103               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20104             enddo
20105             uprod=u(1)
20106             do j=2,nbi
20107               uprod=uprod*u(j)
20108             enddo
20109             usum=0.0d0
20110             usumsqder=0.0d0
20111             do j=1,nbi
20112               uprod1=1.0d0
20113               uprod2=1.0d0
20114               do k=1,nbi
20115                 if (k.ne.j) then
20116                   uprod1=uprod1*u(k)
20117                   uprod2=uprod2*u(k)*u(k)
20118                 endif
20119               enddo
20120               usum=usum+uprod1
20121               usumsqder=usumsqder+ud(j)*uprod2
20122             enddo
20123             estr_nucl=estr_nucl+uprod/usum
20124             do j=1,3
20125              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20126             enddo
20127         endif
20128       enddo
20129 !C      print *,"I am about to leave ebond"
20130       return
20131       end subroutine ebond_nucl
20132
20133 !-----------------------------------------------------------------------------
20134       subroutine ebend_nucl(etheta_nucl)
20135       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20136       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20137       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20138       logical :: lprn=.false., lprn1=.false.
20139 !el local variables
20140       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20141       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20142       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20143 ! local variables for constrains
20144       real(kind=8) :: difi,thetiii
20145        integer itheta
20146       etheta_nucl=0.0D0
20147 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20148       do i=ithet_nucl_start,ithet_nucl_end
20149         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20150         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20151         (itype(i,2).eq.ntyp1_molec(2))) cycle
20152         dethetai=0.0d0
20153         dephii=0.0d0
20154         dephii1=0.0d0
20155         theti2=0.5d0*theta(i)
20156         ityp2=ithetyp_nucl(itype(i-1,2))
20157         do k=1,nntheterm_nucl
20158           coskt(k)=dcos(k*theti2)
20159           sinkt(k)=dsin(k*theti2)
20160         enddo
20161         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20162 #ifdef OSF
20163           phii=phi(i)
20164           if (phii.ne.phii) phii=150.0
20165 #else
20166           phii=phi(i)
20167 #endif
20168           ityp1=ithetyp_nucl(itype(i-2,2))
20169           do k=1,nsingle_nucl
20170             cosph1(k)=dcos(k*phii)
20171             sinph1(k)=dsin(k*phii)
20172           enddo
20173         else
20174           phii=0.0d0
20175           ityp1=nthetyp_nucl+1
20176           do k=1,nsingle_nucl
20177             cosph1(k)=0.0d0
20178             sinph1(k)=0.0d0
20179           enddo
20180         endif
20181
20182         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20183 #ifdef OSF
20184           phii1=phi(i+1)
20185           if (phii1.ne.phii1) phii1=150.0
20186           phii1=pinorm(phii1)
20187 #else
20188           phii1=phi(i+1)
20189 #endif
20190           ityp3=ithetyp_nucl(itype(i,2))
20191           do k=1,nsingle_nucl
20192             cosph2(k)=dcos(k*phii1)
20193             sinph2(k)=dsin(k*phii1)
20194           enddo
20195         else
20196           phii1=0.0d0
20197           ityp3=nthetyp_nucl+1
20198           do k=1,nsingle_nucl
20199             cosph2(k)=0.0d0
20200             sinph2(k)=0.0d0
20201           enddo
20202         endif
20203         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20204         do k=1,ndouble_nucl
20205           do l=1,k-1
20206             ccl=cosph1(l)*cosph2(k-l)
20207             ssl=sinph1(l)*sinph2(k-l)
20208             scl=sinph1(l)*cosph2(k-l)
20209             csl=cosph1(l)*sinph2(k-l)
20210             cosph1ph2(l,k)=ccl-ssl
20211             cosph1ph2(k,l)=ccl+ssl
20212             sinph1ph2(l,k)=scl+csl
20213             sinph1ph2(k,l)=scl-csl
20214           enddo
20215         enddo
20216         if (lprn) then
20217         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20218          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20219         write (iout,*) "coskt and sinkt",nntheterm_nucl
20220         do k=1,nntheterm_nucl
20221           write (iout,*) k,coskt(k),sinkt(k)
20222         enddo
20223         endif
20224         do k=1,ntheterm_nucl
20225           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20226           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20227            *coskt(k)
20228           if (lprn)&
20229          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20230           " ethetai",ethetai
20231         enddo
20232         if (lprn) then
20233         write (iout,*) "cosph and sinph"
20234         do k=1,nsingle_nucl
20235           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20236         enddo
20237         write (iout,*) "cosph1ph2 and sinph2ph2"
20238         do k=2,ndouble_nucl
20239           do l=1,k-1
20240             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20241               sinph1ph2(l,k),sinph1ph2(k,l)
20242           enddo
20243         enddo
20244         write(iout,*) "ethetai",ethetai
20245         endif
20246         do m=1,ntheterm2_nucl
20247           do k=1,nsingle_nucl
20248             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20249               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20250               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20251               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20252             ethetai=ethetai+sinkt(m)*aux
20253             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20254             dephii=dephii+k*sinkt(m)*(&
20255                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20256                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20257             dephii1=dephii1+k*sinkt(m)*(&
20258                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20259                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20260             if (lprn) &
20261            write (iout,*) "m",m," k",k," bbthet",&
20262               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20263               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20264               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20265               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20266           enddo
20267         enddo
20268         if (lprn) &
20269         write(iout,*) "ethetai",ethetai
20270         do m=1,ntheterm3_nucl
20271           do k=2,ndouble_nucl
20272             do l=1,k-1
20273               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20274                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20275                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20276                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20277               ethetai=ethetai+sinkt(m)*aux
20278               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20279               dephii=dephii+l*sinkt(m)*(&
20280                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20281                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20282                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20283                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20284               dephii1=dephii1+(k-l)*sinkt(m)*( &
20285                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20286                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20287                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20288                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20289               if (lprn) then
20290               write (iout,*) "m",m," k",k," l",l," ffthet", &
20291                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20292                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20293                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20294                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20295               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20296                  cosph1ph2(k,l)*sinkt(m),&
20297                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20298               endif
20299             enddo
20300           enddo
20301         enddo
20302 10      continue
20303         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20304         i,theta(i)*rad2deg,phii*rad2deg, &
20305         phii1*rad2deg,ethetai
20306         etheta_nucl=etheta_nucl+ethetai
20307 !        print *,i,"partial sum",etheta_nucl
20308         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20309         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20310         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20311       enddo
20312       return
20313       end subroutine ebend_nucl
20314 !----------------------------------------------------
20315       subroutine etor_nucl(etors_nucl)
20316 !      implicit real*8 (a-h,o-z)
20317 !      include 'DIMENSIONS'
20318 !      include 'COMMON.VAR'
20319 !      include 'COMMON.GEO'
20320 !      include 'COMMON.LOCAL'
20321 !      include 'COMMON.TORSION'
20322 !      include 'COMMON.INTERACT'
20323 !      include 'COMMON.DERIV'
20324 !      include 'COMMON.CHAIN'
20325 !      include 'COMMON.NAMES'
20326 !      include 'COMMON.IOUNITS'
20327 !      include 'COMMON.FFIELD'
20328 !      include 'COMMON.TORCNSTR'
20329 !      include 'COMMON.CONTROL'
20330       real(kind=8) :: etors_nucl,edihcnstr
20331       logical :: lprn
20332 !el local variables
20333       integer :: i,j,iblock,itori,itori1
20334       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20335                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20336 ! Set lprn=.true. for debugging
20337       lprn=.false.
20338 !     lprn=.true.
20339       etors_nucl=0.0D0
20340 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20341       do i=iphi_nucl_start,iphi_nucl_end
20342         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20343              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20344              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20345         etors_ii=0.0D0
20346         itori=itortyp_nucl(itype(i-2,2))
20347         itori1=itortyp_nucl(itype(i-1,2))
20348         phii=phi(i)
20349 !         print *,i,itori,itori1
20350         gloci=0.0D0
20351 !C Regular cosine and sine terms
20352         do j=1,nterm_nucl(itori,itori1)
20353           v1ij=v1_nucl(j,itori,itori1)
20354           v2ij=v2_nucl(j,itori,itori1)
20355           cosphi=dcos(j*phii)
20356           sinphi=dsin(j*phii)
20357           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20358           if (energy_dec) etors_ii=etors_ii+&
20359                      v1ij*cosphi+v2ij*sinphi
20360           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20361         enddo
20362 !C Lorentz terms
20363 !C                         v1
20364 !C  E = SUM ----------------------------------- - v1
20365 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20366 !C
20367         cosphi=dcos(0.5d0*phii)
20368         sinphi=dsin(0.5d0*phii)
20369         do j=1,nlor_nucl(itori,itori1)
20370           vl1ij=vlor1_nucl(j,itori,itori1)
20371           vl2ij=vlor2_nucl(j,itori,itori1)
20372           vl3ij=vlor3_nucl(j,itori,itori1)
20373           pom=vl2ij*cosphi+vl3ij*sinphi
20374           pom1=1.0d0/(pom*pom+1.0d0)
20375           etors_nucl=etors_nucl+vl1ij*pom1
20376           if (energy_dec) etors_ii=etors_ii+ &
20377                      vl1ij*pom1
20378           pom=-pom*pom1*pom1
20379           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20380         enddo
20381 !C Subtract the constant term
20382         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20383           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20384               'etor',i,etors_ii-v0_nucl(itori,itori1)
20385         if (lprn) &
20386        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20387        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20388        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20389         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20390 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20391       enddo
20392       return
20393       end subroutine etor_nucl
20394 !------------------------------------------------------------
20395       subroutine epp_nucl_sub(evdw1,ees)
20396 !C
20397 !C This subroutine calculates the average interaction energy and its gradient
20398 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20399 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20400 !C The potential depends both on the distance of peptide-group centers and on
20401 !C the orientation of the CA-CA virtual bonds.
20402 !C
20403       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20404       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20405       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20406                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20407                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20408       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20409                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20410       integer xshift,yshift,zshift
20411       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20412       real(kind=8) :: ees,eesij
20413 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20414       real(kind=8) scal_el /0.5d0/
20415       t_eelecij=0.0d0
20416       ees=0.0D0
20417       evdw1=0.0D0
20418       ind=0
20419 !c
20420 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20421 !c
20422       print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20423       do i=iatel_s_nucl,iatel_e_nucl
20424         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20425         dxi=dc(1,i)
20426         dyi=dc(2,i)
20427         dzi=dc(3,i)
20428         dx_normi=dc_norm(1,i)
20429         dy_normi=dc_norm(2,i)
20430         dz_normi=dc_norm(3,i)
20431         xmedi=c(1,i)+0.5d0*dxi
20432         ymedi=c(2,i)+0.5d0*dyi
20433         zmedi=c(3,i)+0.5d0*dzi
20434           xmedi=dmod(xmedi,boxxsize)
20435           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20436           ymedi=dmod(ymedi,boxysize)
20437           if (ymedi.lt.0) ymedi=ymedi+boxysize
20438           zmedi=dmod(zmedi,boxzsize)
20439           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20440
20441         do j=ielstart_nucl(i),ielend_nucl(i)
20442           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20443           ind=ind+1
20444           dxj=dc(1,j)
20445           dyj=dc(2,j)
20446           dzj=dc(3,j)
20447 !          xj=c(1,j)+0.5D0*dxj-xmedi
20448 !          yj=c(2,j)+0.5D0*dyj-ymedi
20449 !          zj=c(3,j)+0.5D0*dzj-zmedi
20450           xj=c(1,j)+0.5D0*dxj
20451           yj=c(2,j)+0.5D0*dyj
20452           zj=c(3,j)+0.5D0*dzj
20453           xj=mod(xj,boxxsize)
20454           if (xj.lt.0) xj=xj+boxxsize
20455           yj=mod(yj,boxysize)
20456           if (yj.lt.0) yj=yj+boxysize
20457           zj=mod(zj,boxzsize)
20458           if (zj.lt.0) zj=zj+boxzsize
20459       isubchap=0
20460       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20461       xj_safe=xj
20462       yj_safe=yj
20463       zj_safe=zj
20464       do xshift=-1,1
20465       do yshift=-1,1
20466       do zshift=-1,1
20467           xj=xj_safe+xshift*boxxsize
20468           yj=yj_safe+yshift*boxysize
20469           zj=zj_safe+zshift*boxzsize
20470           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20471           if(dist_temp.lt.dist_init) then
20472             dist_init=dist_temp
20473             xj_temp=xj
20474             yj_temp=yj
20475             zj_temp=zj
20476             isubchap=1
20477           endif
20478        enddo
20479        enddo
20480        enddo
20481        if (isubchap.eq.1) then
20482 !C          print *,i,j
20483           xj=xj_temp-xmedi
20484           yj=yj_temp-ymedi
20485           zj=zj_temp-zmedi
20486        else
20487           xj=xj_safe-xmedi
20488           yj=yj_safe-ymedi
20489           zj=zj_safe-zmedi
20490        endif
20491
20492           rij=xj*xj+yj*yj+zj*zj
20493 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20494           fac=(r0pp**2/rij)**3
20495           ev1=epspp*fac*fac
20496           ev2=epspp*fac
20497           evdw1ij=ev1-2*ev2
20498           fac=(-ev1-evdw1ij)/rij
20499 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20500           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20501           evdw1=evdw1+evdw1ij
20502 !C
20503 !C Calculate contributions to the Cartesian gradient.
20504 !C
20505           ggg(1)=fac*xj
20506           ggg(2)=fac*yj
20507           ggg(3)=fac*zj
20508           do k=1,3
20509             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20510             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20511           enddo
20512 !c phoshate-phosphate electrostatic interactions
20513           rij=dsqrt(rij)
20514           fac=1.0d0/rij
20515           eesij=dexp(-BEES*rij)*fac
20516 !          write (2,*)"fac",fac," eesijpp",eesij
20517           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20518           ees=ees+eesij
20519 !c          fac=-eesij*fac
20520           fac=-(fac+BEES)*eesij*fac
20521           ggg(1)=fac*xj
20522           ggg(2)=fac*yj
20523           ggg(3)=fac*zj
20524 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20525 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20526 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20527           do k=1,3
20528             gelpp(k,i)=gelpp(k,i)-ggg(k)
20529             gelpp(k,j)=gelpp(k,j)+ggg(k)
20530           enddo
20531         enddo ! j
20532       enddo   ! i
20533 !c      ees=332.0d0*ees
20534       ees=AEES*ees
20535       do i=nnt,nct
20536 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20537         do k=1,3
20538           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20539 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20540           gelpp(k,i)=AEES*gelpp(k,i)
20541         enddo
20542 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20543       enddo
20544 !c      write (2,*) "total EES",ees
20545       return
20546       end subroutine epp_nucl_sub
20547 !---------------------------------------------------------------------
20548       subroutine epsb(evdwpsb,eelpsb)
20549 !      use comm_locel
20550 !C
20551 !C This subroutine calculates the excluded-volume interaction energy between
20552 !C peptide-group centers and side chains and its gradient in virtual-bond and
20553 !C side-chain vectors.
20554 !C
20555       real(kind=8),dimension(3):: ggg
20556       integer :: i,iint,j,k,iteli,itypj,subchap
20557       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20558                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20559       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20560                     dist_temp, dist_init
20561       integer xshift,yshift,zshift
20562
20563 !cd    print '(a)','Enter ESCP'
20564 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20565       eelpsb=0.0d0
20566       evdwpsb=0.0d0
20567 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20568       do i=iatscp_s_nucl,iatscp_e_nucl
20569         if (itype(i,2).eq.ntyp1_molec(2) &
20570          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20571         xi=0.5D0*(c(1,i)+c(1,i+1))
20572         yi=0.5D0*(c(2,i)+c(2,i+1))
20573         zi=0.5D0*(c(3,i)+c(3,i+1))
20574           xi=mod(xi,boxxsize)
20575           if (xi.lt.0) xi=xi+boxxsize
20576           yi=mod(yi,boxysize)
20577           if (yi.lt.0) yi=yi+boxysize
20578           zi=mod(zi,boxzsize)
20579           if (zi.lt.0) zi=zi+boxzsize
20580
20581         do iint=1,nscp_gr_nucl(i)
20582
20583         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20584           itypj=itype(j,2)
20585           if (itypj.eq.ntyp1_molec(2)) cycle
20586 !C Uncomment following three lines for SC-p interactions
20587 !c         xj=c(1,nres+j)-xi
20588 !c         yj=c(2,nres+j)-yi
20589 !c         zj=c(3,nres+j)-zi
20590 !C Uncomment following three lines for Ca-p interactions
20591 !          xj=c(1,j)-xi
20592 !          yj=c(2,j)-yi
20593 !          zj=c(3,j)-zi
20594           xj=c(1,j)
20595           yj=c(2,j)
20596           zj=c(3,j)
20597           xj=mod(xj,boxxsize)
20598           if (xj.lt.0) xj=xj+boxxsize
20599           yj=mod(yj,boxysize)
20600           if (yj.lt.0) yj=yj+boxysize
20601           zj=mod(zj,boxzsize)
20602           if (zj.lt.0) zj=zj+boxzsize
20603       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20604       xj_safe=xj
20605       yj_safe=yj
20606       zj_safe=zj
20607       subchap=0
20608       do xshift=-1,1
20609       do yshift=-1,1
20610       do zshift=-1,1
20611           xj=xj_safe+xshift*boxxsize
20612           yj=yj_safe+yshift*boxysize
20613           zj=zj_safe+zshift*boxzsize
20614           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20615           if(dist_temp.lt.dist_init) then
20616             dist_init=dist_temp
20617             xj_temp=xj
20618             yj_temp=yj
20619             zj_temp=zj
20620             subchap=1
20621           endif
20622        enddo
20623        enddo
20624        enddo
20625        if (subchap.eq.1) then
20626           xj=xj_temp-xi
20627           yj=yj_temp-yi
20628           zj=zj_temp-zi
20629        else
20630           xj=xj_safe-xi
20631           yj=yj_safe-yi
20632           zj=zj_safe-zi
20633        endif
20634
20635           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20636           fac=rrij**expon2
20637           e1=fac*fac*aad_nucl(itypj)
20638           e2=fac*bad_nucl(itypj)
20639           if (iabs(j-i) .le. 2) then
20640             e1=scal14*e1
20641             e2=scal14*e2
20642           endif
20643           evdwij=e1+e2
20644           evdwpsb=evdwpsb+evdwij
20645           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20646              'evdw2',i,j,evdwij,"tu4"
20647 !C
20648 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20649 !C
20650           fac=-(evdwij+e1)*rrij
20651           ggg(1)=xj*fac
20652           ggg(2)=yj*fac
20653           ggg(3)=zj*fac
20654           do k=1,3
20655             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20656             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20657           enddo
20658         enddo
20659
20660         enddo ! iint
20661       enddo ! i
20662       do i=1,nct
20663         do j=1,3
20664           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20665           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20666         enddo
20667       enddo
20668       return
20669       end subroutine epsb
20670
20671 !------------------------------------------------------
20672       subroutine esb_gb(evdwsb,eelsb)
20673       use comm_locel
20674       use calc_data_nucl
20675       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20676       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20677       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20678       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20679                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20680       integer :: ii
20681       logical lprn
20682       evdw=0.0D0
20683       eelsb=0.0d0
20684       ecorr=0.0d0
20685       evdwsb=0.0D0
20686       lprn=.false.
20687       ind=0
20688 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20689       do i=iatsc_s_nucl,iatsc_e_nucl
20690         num_conti=0
20691         num_conti2=0
20692         itypi=itype(i,2)
20693 !        PRINT *,"I=",i,itypi
20694         if (itypi.eq.ntyp1_molec(2)) cycle
20695         itypi1=itype(i+1,2)
20696         xi=c(1,nres+i)
20697         yi=c(2,nres+i)
20698         zi=c(3,nres+i)
20699           xi=dmod(xi,boxxsize)
20700           if (xi.lt.0) xi=xi+boxxsize
20701           yi=dmod(yi,boxysize)
20702           if (yi.lt.0) yi=yi+boxysize
20703           zi=dmod(zi,boxzsize)
20704           if (zi.lt.0) zi=zi+boxzsize
20705
20706         dxi=dc_norm(1,nres+i)
20707         dyi=dc_norm(2,nres+i)
20708         dzi=dc_norm(3,nres+i)
20709         dsci_inv=vbld_inv(i+nres)
20710 !C
20711 !C Calculate SC interaction energy.
20712 !C
20713         do iint=1,nint_gr_nucl(i)
20714 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20715           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20716             ind=ind+1
20717 !            print *,"JESTEM"
20718             itypj=itype(j,2)
20719             if (itypj.eq.ntyp1_molec(2)) cycle
20720             dscj_inv=vbld_inv(j+nres)
20721             sig0ij=sigma_nucl(itypi,itypj)
20722             chi1=chi_nucl(itypi,itypj)
20723             chi2=chi_nucl(itypj,itypi)
20724             chi12=chi1*chi2
20725             chip1=chip_nucl(itypi,itypj)
20726             chip2=chip_nucl(itypj,itypi)
20727             chip12=chip1*chip2
20728 !            xj=c(1,nres+j)-xi
20729 !            yj=c(2,nres+j)-yi
20730 !            zj=c(3,nres+j)-zi
20731            xj=c(1,nres+j)
20732            yj=c(2,nres+j)
20733            zj=c(3,nres+j)
20734           xj=dmod(xj,boxxsize)
20735           if (xj.lt.0) xj=xj+boxxsize
20736           yj=dmod(yj,boxysize)
20737           if (yj.lt.0) yj=yj+boxysize
20738           zj=dmod(zj,boxzsize)
20739           if (zj.lt.0) zj=zj+boxzsize
20740       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20741       xj_safe=xj
20742       yj_safe=yj
20743       zj_safe=zj
20744       subchap=0
20745       do xshift=-1,1
20746       do yshift=-1,1
20747       do zshift=-1,1
20748           xj=xj_safe+xshift*boxxsize
20749           yj=yj_safe+yshift*boxysize
20750           zj=zj_safe+zshift*boxzsize
20751           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20752           if(dist_temp.lt.dist_init) then
20753             dist_init=dist_temp
20754             xj_temp=xj
20755             yj_temp=yj
20756             zj_temp=zj
20757             subchap=1
20758           endif
20759        enddo
20760        enddo
20761        enddo
20762        if (subchap.eq.1) then
20763           xj=xj_temp-xi
20764           yj=yj_temp-yi
20765           zj=zj_temp-zi
20766        else
20767           xj=xj_safe-xi
20768           yj=yj_safe-yi
20769           zj=zj_safe-zi
20770        endif
20771
20772             dxj=dc_norm(1,nres+j)
20773             dyj=dc_norm(2,nres+j)
20774             dzj=dc_norm(3,nres+j)
20775             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20776             rij=dsqrt(rrij)
20777 !C Calculate angle-dependent terms of energy and contributions to their
20778 !C derivatives.
20779             erij(1)=xj*rij
20780             erij(2)=yj*rij
20781             erij(3)=zj*rij
20782             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20783             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20784             om12=dxi*dxj+dyi*dyj+dzi*dzj
20785             call sc_angular_nucl
20786             sigsq=1.0D0/sigsq
20787             sig=sig0ij*dsqrt(sigsq)
20788             rij_shift=1.0D0/rij-sig+sig0ij
20789 !            print *,rij_shift,"rij_shift"
20790 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20791 !c     &       " rij_shift",rij_shift
20792             if (rij_shift.le.0.0D0) then
20793               evdw=1.0D20
20794               return
20795             endif
20796             sigder=-sig*sigsq
20797 !c---------------------------------------------------------------
20798             rij_shift=1.0D0/rij_shift
20799             fac=rij_shift**expon
20800             e1=fac*fac*aa_nucl(itypi,itypj)
20801             e2=fac*bb_nucl(itypi,itypj)
20802             evdwij=eps1*eps2rt*(e1+e2)
20803 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20804 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20805             eps2der=evdwij
20806             evdwij=evdwij*eps2rt
20807             evdwsb=evdwsb+evdwij
20808             if (lprn) then
20809             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
20810             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
20811             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20812              restyp(itypi,2),i,restyp(itypj,2),j, &
20813              epsi,sigm,chi1,chi2,chip1,chip2, &
20814              eps1,eps2rt**2,sig,sig0ij, &
20815              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20816             evdwij
20817             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20818             endif
20819
20820             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20821                              'evdw',i,j,evdwij,"tu3"
20822
20823
20824 !C Calculate gradient components.
20825             e1=e1*eps1*eps2rt**2
20826             fac=-expon*(e1+evdwij)*rij_shift
20827             sigder=fac*sigder
20828             fac=rij*fac
20829 !c            fac=0.0d0
20830 !C Calculate the radial part of the gradient
20831             gg(1)=xj*fac
20832             gg(2)=yj*fac
20833             gg(3)=zj*fac
20834 !C Calculate angular part of the gradient.
20835             call sc_grad_nucl
20836             call eelsbij(eelij,num_conti2)
20837             if (energy_dec .and. &
20838            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20839           write (istat,'(e14.5)') evdwij
20840             eelsb=eelsb+eelij
20841           enddo      ! j
20842         enddo        ! iint
20843         num_cont_hb(i)=num_conti2
20844       enddo          ! i
20845 !c      write (iout,*) "Number of loop steps in EGB:",ind
20846 !cccc      energy_dec=.false.
20847       return
20848       end subroutine esb_gb
20849 !-------------------------------------------------------------------------------
20850       subroutine eelsbij(eesij,num_conti2)
20851       use comm_locel
20852       use calc_data_nucl
20853       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20854       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20855       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20856                     dist_temp, dist_init,rlocshield,fracinbuf
20857       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20858
20859 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20860       real(kind=8) scal_el /0.5d0/
20861       integer :: iteli,itelj,kkk,kkll,m,isubchap
20862       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20863       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20864       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20865                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20866                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20867                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20868                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20869                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20870                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20871                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20872       ind=ind+1
20873       itypi=itype(i,2)
20874       itypj=itype(j,2)
20875 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20876       ael6i=ael6_nucl(itypi,itypj)
20877       ael3i=ael3_nucl(itypi,itypj)
20878       ael63i=ael63_nucl(itypi,itypj)
20879       ael32i=ael32_nucl(itypi,itypj)
20880 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20881 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20882       dxj=dc(1,j+nres)
20883       dyj=dc(2,j+nres)
20884       dzj=dc(3,j+nres)
20885       dx_normi=dc_norm(1,i+nres)
20886       dy_normi=dc_norm(2,i+nres)
20887       dz_normi=dc_norm(3,i+nres)
20888       dx_normj=dc_norm(1,j+nres)
20889       dy_normj=dc_norm(2,j+nres)
20890       dz_normj=dc_norm(3,j+nres)
20891 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20892 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20893 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20894       if (ipot_nucl.ne.2) then
20895         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20896         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20897         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20898       else
20899         cosa=om12
20900         cosb=om1
20901         cosg=om2
20902       endif
20903       r3ij=rij*rrij
20904       r6ij=r3ij*r3ij
20905       fac=cosa-3.0D0*cosb*cosg
20906       facfac=fac*fac
20907       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20908       fac3=ael6i*r6ij
20909       fac4=ael3i*r3ij
20910       fac5=ael63i*r6ij
20911       fac6=ael32i*r6ij
20912 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20913 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20914       el1=fac3*(4.0D0+facfac-fac1)
20915       el2=fac4*fac
20916       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20917       el4=fac6*facfac
20918       eesij=el1+el2+el3+el4
20919 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20920       ees0ij=4.0D0+facfac-fac1
20921
20922       if (energy_dec) then
20923           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20924           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20925            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20926            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20927            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20928           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20929       endif
20930
20931 !C
20932 !C Calculate contributions to the Cartesian gradient.
20933 !C
20934       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20935       fac1=fac
20936 !c      erij(1)=xj*rmij
20937 !c      erij(2)=yj*rmij
20938 !c      erij(3)=zj*rmij
20939 !*
20940 !* Radial derivatives. First process both termini of the fragment (i,j)
20941 !*
20942       ggg(1)=facel*xj
20943       ggg(2)=facel*yj
20944       ggg(3)=facel*zj
20945       do k=1,3
20946         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20947         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20948         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20949         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20950       enddo
20951 !*
20952 !* Angular part
20953 !*
20954       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20955       fac4=-3.0D0*fac4
20956       fac3=-6.0D0*fac3
20957       fac5= 6.0d0*fac5
20958       fac6=-6.0d0*fac6
20959       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20960        fac6*fac1*cosg
20961       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20962        fac6*fac1*cosb
20963       do k=1,3
20964         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20965         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20966       enddo
20967       do k=1,3
20968         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20969       enddo
20970       do k=1,3
20971         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20972              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20973              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20974         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20975              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20976              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20977         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20978         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20979       enddo
20980 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
20981        IF ( j.gt.i+1 .and.&
20982           num_conti.le.maxconts) THEN
20983 !C
20984 !C Calculate the contact function. The ith column of the array JCONT will
20985 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20986 !C greater than I). The arrays FACONT and GACONT will contain the values of
20987 !C the contact function and its derivative.
20988         r0ij=2.20D0*sigma(itypi,itypj)
20989 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20990         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20991 !c        write (2,*) "fcont",fcont
20992         if (fcont.gt.0.0D0) then
20993           num_conti=num_conti+1
20994           num_conti2=num_conti2+1
20995
20996           if (num_conti.gt.maxconts) then
20997             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20998                           ' will skip next contacts for this conf.'
20999           else
21000             jcont_hb(num_conti,i)=j
21001 !c            write (iout,*) "num_conti",num_conti,
21002 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21003 !C Calculate contact energies
21004             cosa4=4.0D0*cosa
21005             wij=cosa-3.0D0*cosb*cosg
21006             cosbg1=cosb+cosg
21007             cosbg2=cosb-cosg
21008             fac3=dsqrt(-ael6i)*r3ij
21009 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21010             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21011             if (ees0tmp.gt.0) then
21012               ees0pij=dsqrt(ees0tmp)
21013             else
21014               ees0pij=0
21015             endif
21016             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21017             if (ees0tmp.gt.0) then
21018               ees0mij=dsqrt(ees0tmp)
21019             else
21020               ees0mij=0
21021             endif
21022             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21023             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21024 !c            write (iout,*) "i",i," j",j,
21025 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21026             ees0pij1=fac3/ees0pij
21027             ees0mij1=fac3/ees0mij
21028             fac3p=-3.0D0*fac3*rrij
21029             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21030             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21031             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21032             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21033             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21034             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21035             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21036             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21037             ecosap=ecosa1+ecosa2
21038             ecosbp=ecosb1+ecosb2
21039             ecosgp=ecosg1+ecosg2
21040             ecosam=ecosa1-ecosa2
21041             ecosbm=ecosb1-ecosb2
21042             ecosgm=ecosg1-ecosg2
21043 !C End diagnostics
21044             facont_hb(num_conti,i)=fcont
21045             fprimcont=fprimcont/rij
21046             do k=1,3
21047               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21048               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21049             enddo
21050             gggp(1)=gggp(1)+ees0pijp*xj
21051             gggp(2)=gggp(2)+ees0pijp*yj
21052             gggp(3)=gggp(3)+ees0pijp*zj
21053             gggm(1)=gggm(1)+ees0mijp*xj
21054             gggm(2)=gggm(2)+ees0mijp*yj
21055             gggm(3)=gggm(3)+ees0mijp*zj
21056 !C Derivatives due to the contact function
21057             gacont_hbr(1,num_conti,i)=fprimcont*xj
21058             gacont_hbr(2,num_conti,i)=fprimcont*yj
21059             gacont_hbr(3,num_conti,i)=fprimcont*zj
21060             do k=1,3
21061 !c
21062 !c Gradient of the correlation terms
21063 !c
21064               gacontp_hb1(k,num_conti,i)= &
21065              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21066             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21067               gacontp_hb2(k,num_conti,i)= &
21068              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21069             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21070               gacontp_hb3(k,num_conti,i)=gggp(k)
21071               gacontm_hb1(k,num_conti,i)= &
21072              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21073             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21074               gacontm_hb2(k,num_conti,i)= &
21075              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21076             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21077               gacontm_hb3(k,num_conti,i)=gggm(k)
21078             enddo
21079           endif
21080         endif
21081       ENDIF
21082       return
21083       end subroutine eelsbij
21084 !------------------------------------------------------------------
21085       subroutine sc_grad_nucl
21086       use comm_locel
21087       use calc_data_nucl
21088       real(kind=8),dimension(3) :: dcosom1,dcosom2
21089       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21090       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21091       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21092       do k=1,3
21093         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21094         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21095       enddo
21096       do k=1,3
21097         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21098       enddo
21099       do k=1,3
21100         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21101                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21102                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21103         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21104                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21105                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21106       enddo
21107 !C
21108 !C Calculate the components of the gradient in DC and X
21109 !C
21110       do l=1,3
21111         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21112         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21113       enddo
21114       return
21115       end subroutine sc_grad_nucl
21116 !-----------------------------------------------------------------------
21117       subroutine esb(esbloc)
21118 !C Calculate the local energy of a side chain and its derivatives in the
21119 !C corresponding virtual-bond valence angles THETA and the spherical angles
21120 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21121 !C added by Urszula Kozlowska. 07/11/2007
21122 !C
21123       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21124       real(kind=8),dimension(9):: x
21125      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21126       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21127       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21128       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21129        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21130        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21131        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21132        integer::it,nlobit,i,j,k
21133 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21134       delta=0.02d0*pi
21135       esbloc=0.0D0
21136       do i=loc_start_nucl,loc_end_nucl
21137         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21138         costtab(i+1) =dcos(theta(i+1))
21139         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21140         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21141         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21142         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21143         cosfac=dsqrt(cosfac2)
21144         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21145         sinfac=dsqrt(sinfac2)
21146         it=itype(i,2)
21147         if (it.eq.10) goto 1
21148
21149 !c
21150 !C  Compute the axes of tghe local cartesian coordinates system; store in
21151 !c   x_prime, y_prime and z_prime
21152 !c
21153         do j=1,3
21154           x_prime(j) = 0.00
21155           y_prime(j) = 0.00
21156           z_prime(j) = 0.00
21157         enddo
21158 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21159 !C     &   dc_norm(3,i+nres)
21160         do j = 1,3
21161           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21162           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21163         enddo
21164         do j = 1,3
21165           z_prime(j) = -uz(j,i-1)
21166 !           z_prime(j)=0.0
21167         enddo
21168
21169         xx=0.0d0
21170         yy=0.0d0
21171         zz=0.0d0
21172         do j = 1,3
21173           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21174           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21175           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21176         enddo
21177
21178         xxtab(i)=xx
21179         yytab(i)=yy
21180         zztab(i)=zz
21181          it=itype(i,2)
21182         do j = 1,9
21183           x(j) = sc_parmin_nucl(j,it)
21184         enddo
21185 #ifdef CHECK_COORD
21186 !Cc diagnostics - remove later
21187         xx1 = dcos(alph(2))
21188         yy1 = dsin(alph(2))*dcos(omeg(2))
21189         zz1 = -dsin(alph(2))*dsin(omeg(2))
21190         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21191          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21192          xx1,yy1,zz1
21193 !C,"  --- ", xx_w,yy_w,zz_w
21194 !c end diagnostics
21195 #endif
21196         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21197         esbloc = esbloc + sumene
21198         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21199 !        print *,"enecomp",sumene,sumene2
21200 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21201 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21202 #ifdef DEBUG
21203         write (2,*) "x",(x(k),k=1,9)
21204 !C
21205 !C This section to check the numerical derivatives of the energy of ith side
21206 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21207 !C #define DEBUG in the code to turn it on.
21208 !C
21209         write (2,*) "sumene               =",sumene
21210         aincr=1.0d-7
21211         xxsave=xx
21212         xx=xx+aincr
21213         write (2,*) xx,yy,zz
21214         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21215         de_dxx_num=(sumenep-sumene)/aincr
21216         xx=xxsave
21217         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21218         yysave=yy
21219         yy=yy+aincr
21220         write (2,*) xx,yy,zz
21221         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21222         de_dyy_num=(sumenep-sumene)/aincr
21223         yy=yysave
21224         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21225         zzsave=zz
21226         zz=zz+aincr
21227         write (2,*) xx,yy,zz
21228         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21229         de_dzz_num=(sumenep-sumene)/aincr
21230         zz=zzsave
21231         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21232         costsave=cost2tab(i+1)
21233         sintsave=sint2tab(i+1)
21234         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21235         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21236         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21237         de_dt_num=(sumenep-sumene)/aincr
21238         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21239         cost2tab(i+1)=costsave
21240         sint2tab(i+1)=sintsave
21241 !C End of diagnostics section.
21242 #endif
21243 !C
21244 !C Compute the gradient of esc
21245 !C
21246         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21247         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21248         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21249         de_dtt=0.0d0
21250 #ifdef DEBUG
21251         write (2,*) "x",(x(k),k=1,9)
21252         write (2,*) "xx",xx," yy",yy," zz",zz
21253         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21254           " de_zz   ",de_zz," de_tt   ",de_tt
21255         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21256           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21257 #endif
21258 !C
21259        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21260        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21261        cosfac2xx=cosfac2*xx
21262        sinfac2yy=sinfac2*yy
21263        do k = 1,3
21264          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21265            vbld_inv(i+1)
21266          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21267            vbld_inv(i)
21268          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21269          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21270 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21271 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21272 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21273 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21274          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21275          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21276          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21277          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21278          dZZ_Ci1(k)=0.0d0
21279          dZZ_Ci(k)=0.0d0
21280          do j=1,3
21281            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21282            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21283          enddo
21284
21285          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21286          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21287          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21288 !c
21289          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21290          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21291        enddo
21292
21293        do k=1,3
21294          dXX_Ctab(k,i)=dXX_Ci(k)
21295          dXX_C1tab(k,i)=dXX_Ci1(k)
21296          dYY_Ctab(k,i)=dYY_Ci(k)
21297          dYY_C1tab(k,i)=dYY_Ci1(k)
21298          dZZ_Ctab(k,i)=dZZ_Ci(k)
21299          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21300          dXX_XYZtab(k,i)=dXX_XYZ(k)
21301          dYY_XYZtab(k,i)=dYY_XYZ(k)
21302          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21303        enddo
21304        do k = 1,3
21305 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21306 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21307 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21308 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21309 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21310 !c     &    dt_dci(k)
21311 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21312 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21313          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21314          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21315          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21316          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21317          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21318          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21319 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21320        enddo
21321 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21322 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21323
21324 !C to check gradient call subroutine check_grad
21325
21326     1 continue
21327       enddo
21328       return
21329       end subroutine esb
21330 !=-------------------------------------------------------
21331       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21332 !      implicit none
21333       real(kind=8),dimension(9):: x(9)
21334        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21335       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21336       integer i
21337 !c      write (2,*) "enesc"
21338 !c      write (2,*) "x",(x(i),i=1,9)
21339 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21340       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21341         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21342         + x(9)*yy*zz
21343       enesc_nucl=sumene
21344       return
21345       end function enesc_nucl
21346 !-----------------------------------------------------------------------------
21347       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21348 #ifdef MPI
21349       include 'mpif.h'
21350       integer,parameter :: max_cont=2000
21351       integer,parameter:: max_dim=2*(8*3+6)
21352       integer, parameter :: msglen1=max_cont*max_dim
21353       integer,parameter :: msglen2=2*msglen1
21354       integer source,CorrelType,CorrelID,Error
21355       real(kind=8) :: buffer(max_cont,max_dim)
21356       integer status(MPI_STATUS_SIZE)
21357       integer :: ierror,nbytes
21358 #endif
21359       real(kind=8),dimension(3):: gx(3),gx1(3)
21360       real(kind=8) :: time00
21361       logical lprn,ldone
21362       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21363       real(kind=8) ecorr,ecorr3
21364       integer :: n_corr,n_corr1,mm,msglen
21365 !C Set lprn=.true. for debugging
21366       lprn=.false.
21367       n_corr=0
21368       n_corr1=0
21369 #ifdef MPI
21370       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21371
21372       if (nfgtasks.le.1) goto 30
21373       if (lprn) then
21374         write (iout,'(a)') 'Contact function values:'
21375         do i=nnt,nct-1
21376           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21377          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21378          j=1,num_cont_hb(i))
21379         enddo
21380       endif
21381 !C Caution! Following code assumes that electrostatic interactions concerning
21382 !C a given atom are split among at most two processors!
21383       CorrelType=477
21384       CorrelID=fg_rank+1
21385       ldone=.false.
21386       do i=1,max_cont
21387         do j=1,max_dim
21388           buffer(i,j)=0.0D0
21389         enddo
21390       enddo
21391       mm=mod(fg_rank,2)
21392 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21393       if (mm) 20,20,10
21394    10 continue
21395 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21396       if (fg_rank.gt.0) then
21397 !C Send correlation contributions to the preceding processor
21398         msglen=msglen1
21399         nn=num_cont_hb(iatel_s_nucl)
21400         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21401 !c        write (*,*) 'The BUFFER array:'
21402 !c        do i=1,nn
21403 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21404 !c        enddo
21405         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21406           msglen=msglen2
21407           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21408 !C Clear the contacts of the atom passed to the neighboring processor
21409         nn=num_cont_hb(iatel_s_nucl+1)
21410 !c        do i=1,nn
21411 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21412 !c        enddo
21413             num_cont_hb(iatel_s_nucl)=0
21414         endif
21415 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21416 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21417 !cd   & ' msglen=',msglen
21418 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21419 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21420 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21421         time00=MPI_Wtime()
21422         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21423          CorrelType,FG_COMM,IERROR)
21424         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21425 !cd      write (iout,*) 'Processor ',fg_rank,
21426 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21427 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21428 !c        write (*,*) 'Processor ',fg_rank,
21429 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21430 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21431 !c        msglen=msglen1
21432       endif ! (fg_rank.gt.0)
21433       if (ldone) goto 30
21434       ldone=.true.
21435    20 continue
21436 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21437       if (fg_rank.lt.nfgtasks-1) then
21438 !C Receive correlation contributions from the next processor
21439         msglen=msglen1
21440         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21441 !cd      write (iout,*) 'Processor',fg_rank,
21442 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21443 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21444 !c        write (*,*) 'Processor',fg_rank,
21445 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21446 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21447         time00=MPI_Wtime()
21448         nbytes=-1
21449         do while (nbytes.le.0)
21450           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21451           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21452         enddo
21453 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21454         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21455          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21456         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21457 !c        write (*,*) 'Processor',fg_rank,
21458 !c     &' has received correlation contribution from processor',fg_rank+1,
21459 !c     & ' msglen=',msglen,' nbytes=',nbytes
21460 !c        write (*,*) 'The received BUFFER array:'
21461 !c        do i=1,max_cont
21462 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21463 !c        enddo
21464         if (msglen.eq.msglen1) then
21465           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21466         else if (msglen.eq.msglen2)  then
21467           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21468           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21469         else
21470           write (iout,*) &
21471       'ERROR!!!! message length changed while processing correlations.'
21472           write (*,*) &
21473       'ERROR!!!! message length changed while processing correlations.'
21474           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21475         endif ! msglen.eq.msglen1
21476       endif ! fg_rank.lt.nfgtasks-1
21477       if (ldone) goto 30
21478       ldone=.true.
21479       goto 10
21480    30 continue
21481 #endif
21482       if (lprn) then
21483         write (iout,'(a)') 'Contact function values:'
21484         do i=nnt_molec(2),nct_molec(2)-1
21485           write (iout,'(2i3,50(1x,i2,f5.2))') &
21486          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21487          j=1,num_cont_hb(i))
21488         enddo
21489       endif
21490       ecorr=0.0D0
21491       ecorr3=0.0d0
21492 !C Remove the loop below after debugging !!!
21493 !      do i=nnt_molec(2),nct_molec(2)
21494 !        do j=1,3
21495 !          gradcorr_nucl(j,i)=0.0D0
21496 !          gradxorr_nucl(j,i)=0.0D0
21497 !          gradcorr3_nucl(j,i)=0.0D0
21498 !          gradxorr3_nucl(j,i)=0.0D0
21499 !        enddo
21500 !      enddo
21501 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21502 !C Calculate the local-electrostatic correlation terms
21503       do i=iatsc_s_nucl,iatsc_e_nucl
21504         i1=i+1
21505         num_conti=num_cont_hb(i)
21506         num_conti1=num_cont_hb(i+1)
21507 !        print *,i,num_conti,num_conti1
21508         do jj=1,num_conti
21509           j=jcont_hb(jj,i)
21510           do kk=1,num_conti1
21511             j1=jcont_hb(kk,i1)
21512 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21513 !c     &         ' jj=',jj,' kk=',kk
21514             if (j1.eq.j+1 .or. j1.eq.j-1) then
21515 !C
21516 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21517 !C The system gains extra energy.
21518 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21519 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21520 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21521 !C
21522               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21523               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21524                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21525               n_corr=n_corr+1
21526             else if (j1.eq.j) then
21527 !C
21528 !C Contacts I-J and I-(J+1) occur simultaneously.
21529 !C The system loses extra energy.
21530 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21531 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21532 !C Need to implement full formulas 32 from Liwo et al., 1998.
21533 !C
21534 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21535 !c     &         ' jj=',jj,' kk=',kk
21536               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21537             endif
21538           enddo ! kk
21539           do kk=1,num_conti
21540             j1=jcont_hb(kk,i)
21541 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21542 !c     &         ' jj=',jj,' kk=',kk
21543             if (j1.eq.j+1) then
21544 !C Contacts I-J and (I+1)-J occur simultaneously.
21545 !C The system loses extra energy.
21546               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21547             endif ! j1==j+1
21548           enddo ! kk
21549         enddo ! jj
21550       enddo ! i
21551       return
21552       end subroutine multibody_hb_nucl
21553 !-----------------------------------------------------------
21554       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21555 !      implicit real*8 (a-h,o-z)
21556 !      include 'DIMENSIONS'
21557 !      include 'COMMON.IOUNITS'
21558 !      include 'COMMON.DERIV'
21559 !      include 'COMMON.INTERACT'
21560 !      include 'COMMON.CONTACTS'
21561       real(kind=8),dimension(3) :: gx,gx1
21562       logical :: lprn
21563 !el local variables
21564       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21565       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21566                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21567                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21568                    rlocshield
21569
21570       lprn=.false.
21571       eij=facont_hb(jj,i)
21572       ekl=facont_hb(kk,k)
21573       ees0pij=ees0p(jj,i)
21574       ees0pkl=ees0p(kk,k)
21575       ees0mij=ees0m(jj,i)
21576       ees0mkl=ees0m(kk,k)
21577       ekont=eij*ekl
21578       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21579 !      print *,"ehbcorr_nucl",ekont,ees
21580 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21581 !C Following 4 lines for diagnostics.
21582 !cd    ees0pkl=0.0D0
21583 !cd    ees0pij=1.0D0
21584 !cd    ees0mkl=0.0D0
21585 !cd    ees0mij=1.0D0
21586 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21587 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21588 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21589 !C Calculate the multi-body contribution to energy.
21590 !      ecorr_nucl=ecorr_nucl+ekont*ees
21591 !C Calculate multi-body contributions to the gradient.
21592       coeffpees0pij=coeffp*ees0pij
21593       coeffmees0mij=coeffm*ees0mij
21594       coeffpees0pkl=coeffp*ees0pkl
21595       coeffmees0mkl=coeffm*ees0mkl
21596       do ll=1,3
21597         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21598        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21599        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21600         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21601         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21602         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21603         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21604         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21605         coeffmees0mij*gacontm_hb1(ll,kk,k))
21606         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21607         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21608         coeffmees0mij*gacontm_hb2(ll,kk,k))
21609         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21610           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21611           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21612         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21613         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21614         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21615           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21616           coeffmees0mij*gacontm_hb3(ll,kk,k))
21617         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21618         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21619         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21620         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21621         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21622         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21623       enddo
21624       ehbcorr_nucl=ekont*ees
21625       return
21626       end function ehbcorr_nucl
21627 !-------------------------------------------------------------------------
21628
21629      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21630 !      implicit real*8 (a-h,o-z)
21631 !      include 'DIMENSIONS'
21632 !      include 'COMMON.IOUNITS'
21633 !      include 'COMMON.DERIV'
21634 !      include 'COMMON.INTERACT'
21635 !      include 'COMMON.CONTACTS'
21636       real(kind=8),dimension(3) :: gx,gx1
21637       logical :: lprn
21638 !el local variables
21639       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21640       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21641                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21642                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21643                    rlocshield
21644
21645       lprn=.false.
21646       eij=facont_hb(jj,i)
21647       ekl=facont_hb(kk,k)
21648       ees0pij=ees0p(jj,i)
21649       ees0pkl=ees0p(kk,k)
21650       ees0mij=ees0m(jj,i)
21651       ees0mkl=ees0m(kk,k)
21652       ekont=eij*ekl
21653       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21654 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21655 !C Following 4 lines for diagnostics.
21656 !cd    ees0pkl=0.0D0
21657 !cd    ees0pij=1.0D0
21658 !cd    ees0mkl=0.0D0
21659 !cd    ees0mij=1.0D0
21660 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21661 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21662 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21663 !C Calculate the multi-body contribution to energy.
21664 !      ecorr=ecorr+ekont*ees
21665 !C Calculate multi-body contributions to the gradient.
21666       coeffpees0pij=coeffp*ees0pij
21667       coeffmees0mij=coeffm*ees0mij
21668       coeffpees0pkl=coeffp*ees0pkl
21669       coeffmees0mkl=coeffm*ees0mkl
21670       do ll=1,3
21671         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21672        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21673        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21674         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21675         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21676         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21677         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21678         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21679         coeffmees0mij*gacontm_hb1(ll,kk,k))
21680         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21681         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21682         coeffmees0mij*gacontm_hb2(ll,kk,k))
21683         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21684           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21685           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21686         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21687         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21688         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21689           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21690           coeffmees0mij*gacontm_hb3(ll,kk,k))
21691         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21692         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21693         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21694         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21695         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21696         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21697       enddo
21698       ehbcorr3_nucl=ekont*ees
21699       return
21700       end function ehbcorr3_nucl
21701 #ifdef MPI
21702       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21703       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21704       real(kind=8):: buffer(dimen1,dimen2)
21705       num_kont=num_cont_hb(atom)
21706       do i=1,num_kont
21707         do k=1,8
21708           do j=1,3
21709             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21710           enddo ! j
21711         enddo ! k
21712         buffer(i,indx+25)=facont_hb(i,atom)
21713         buffer(i,indx+26)=ees0p(i,atom)
21714         buffer(i,indx+27)=ees0m(i,atom)
21715         buffer(i,indx+28)=d_cont(i,atom)
21716         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21717       enddo ! i
21718       buffer(1,indx+30)=dfloat(num_kont)
21719       return
21720       end subroutine pack_buffer
21721 !c------------------------------------------------------------------------------
21722       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21723       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21724       real(kind=8):: buffer(dimen1,dimen2)
21725 !      double precision zapas
21726 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21727 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21728 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21729 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21730       num_kont=buffer(1,indx+30)
21731       num_kont_old=num_cont_hb(atom)
21732       num_cont_hb(atom)=num_kont+num_kont_old
21733       do i=1,num_kont
21734         ii=i+num_kont_old
21735         do k=1,8
21736           do j=1,3
21737             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21738           enddo ! j
21739         enddo ! k
21740         facont_hb(ii,atom)=buffer(i,indx+25)
21741         ees0p(ii,atom)=buffer(i,indx+26)
21742         ees0m(ii,atom)=buffer(i,indx+27)
21743         d_cont(i,atom)=buffer(i,indx+28)
21744         jcont_hb(ii,atom)=buffer(i,indx+29)
21745       enddo ! i
21746       return
21747       end subroutine unpack_buffer
21748 !c------------------------------------------------------------------------------
21749 #endif
21750       subroutine ecatcat(ecationcation)
21751         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21752         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21753         r7,r4,ecationcation,k0,rcal
21754         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21755         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21756         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21757         gg,r
21758
21759         ecationcation=0.0d0
21760         if (nres_molec(5).eq.0) return
21761         rcat0=3.472
21762         epscalc=0.05
21763         r06 = rcat0**6
21764         r012 = r06**2
21765         k0 = 332.0*(2.0*2.0)/80.0
21766         itmp=0
21767         do i=1,4
21768         itmp=itmp+nres_molec(i)
21769         enddo
21770         do i=itmp+1,itmp+nres_molec(5)-1
21771
21772         xi=c(1,i)
21773         yi=c(2,i)
21774         zi=c(3,i)
21775           xi=mod(xi,boxxsize)
21776           if (xi.lt.0) xi=xi+boxxsize
21777           yi=mod(yi,boxysize)
21778           if (yi.lt.0) yi=yi+boxysize
21779           zi=mod(zi,boxzsize)
21780           if (zi.lt.0) zi=zi+boxzsize
21781
21782           do j=i+1,itmp+nres_molec(5)
21783 !           print *,i,j,'catcat'
21784            xj=c(1,j)
21785            yj=c(2,j)
21786            zj=c(3,j)
21787           xj=dmod(xj,boxxsize)
21788           if (xj.lt.0) xj=xj+boxxsize
21789           yj=dmod(yj,boxysize)
21790           if (yj.lt.0) yj=yj+boxysize
21791           zj=dmod(zj,boxzsize)
21792           if (zj.lt.0) zj=zj+boxzsize
21793       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21794       xj_safe=xj
21795       yj_safe=yj
21796       zj_safe=zj
21797       subchap=0
21798       do xshift=-1,1
21799       do yshift=-1,1
21800       do zshift=-1,1
21801           xj=xj_safe+xshift*boxxsize
21802           yj=yj_safe+yshift*boxysize
21803           zj=zj_safe+zshift*boxzsize
21804           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21805           if(dist_temp.lt.dist_init) then
21806             dist_init=dist_temp
21807             xj_temp=xj
21808             yj_temp=yj
21809             zj_temp=zj
21810             subchap=1
21811           endif
21812        enddo
21813        enddo
21814        enddo
21815        if (subchap.eq.1) then
21816           xj=xj_temp-xi
21817           yj=yj_temp-yi
21818           zj=zj_temp-zi
21819        else
21820           xj=xj_safe-xi
21821           yj=yj_safe-yi
21822           zj=zj_safe-zi
21823        endif
21824        rcal =xj**2+yj**2+zj**2
21825         ract=sqrt(rcal)
21826 !        rcat0=3.472
21827 !        epscalc=0.05
21828 !        r06 = rcat0**6
21829 !        r012 = r06**2
21830 !        k0 = 332*(2*2)/80
21831         Evan1cat=epscalc*(r012/rcal**6)
21832         Evan2cat=epscalc*2*(r06/rcal**3)
21833         Eeleccat=k0/ract
21834         r7 = rcal**7
21835         r4 = rcal**4
21836         r(1)=xj
21837         r(2)=yj
21838         r(3)=zj
21839         do k=1,3
21840           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21841           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21842           dEeleccat(k)=-k0*r(k)/ract**3
21843         enddo
21844         do k=1,3
21845           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21846           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
21847           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
21848         enddo
21849
21850         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
21851        enddo
21852        enddo
21853        return
21854        end subroutine ecatcat
21855 !---------------------------------------------------------------------------
21856        subroutine ecat_prot(ecation_prot)
21857        integer i,j,k,subchap,itmp,inum
21858         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21859         r7,r4,ecationcation
21860         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21861         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
21862         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
21863         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
21864         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
21865         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
21866         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
21867         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
21868         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
21869         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
21870         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
21871         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21872         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
21873         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
21874         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
21875         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
21876         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
21877         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
21878         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
21879         dEvan1Cat
21880         real(kind=8),dimension(6) :: vcatprm
21881         ecation_prot=0.0d0
21882 ! first lets calculate interaction with peptide groups
21883         if (nres_molec(5).eq.0) return
21884          wconst=78
21885         wdip =1.092777950857032D2
21886         wdip=wdip/wconst
21887         wmodquad=-2.174122713004870D4
21888         wmodquad=wmodquad/wconst
21889         wquad1 = 3.901232068562804D1
21890         wquad1=wquad1/wconst
21891         wquad2 = 3
21892         wquad2=wquad2/wconst
21893         wvan1 = 0.1
21894         wvan2 = 6
21895         itmp=0
21896         do i=1,4
21897         itmp=itmp+nres_molec(i)
21898         enddo
21899 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
21900         do i=ibond_start,ibond_end
21901 !         cycle
21902          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
21903         xi=0.5d0*(c(1,i)+c(1,i+1))
21904         yi=0.5d0*(c(2,i)+c(2,i+1))
21905         zi=0.5d0*(c(3,i)+c(3,i+1))
21906           xi=mod(xi,boxxsize)
21907           if (xi.lt.0) xi=xi+boxxsize
21908           yi=mod(yi,boxysize)
21909           if (yi.lt.0) yi=yi+boxysize
21910           zi=mod(zi,boxzsize)
21911           if (zi.lt.0) zi=zi+boxzsize
21912
21913          do j=itmp+1,itmp+nres_molec(5)
21914            xj=c(1,j)
21915            yj=c(2,j)
21916            zj=c(3,j)
21917           xj=dmod(xj,boxxsize)
21918           if (xj.lt.0) xj=xj+boxxsize
21919           yj=dmod(yj,boxysize)
21920           if (yj.lt.0) yj=yj+boxysize
21921           zj=dmod(zj,boxzsize)
21922           if (zj.lt.0) zj=zj+boxzsize
21923       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21924       xj_safe=xj
21925       yj_safe=yj
21926       zj_safe=zj
21927       subchap=0
21928       do xshift=-1,1
21929       do yshift=-1,1
21930       do zshift=-1,1
21931           xj=xj_safe+xshift*boxxsize
21932           yj=yj_safe+yshift*boxysize
21933           zj=zj_safe+zshift*boxzsize
21934           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21935           if(dist_temp.lt.dist_init) then
21936             dist_init=dist_temp
21937             xj_temp=xj
21938             yj_temp=yj
21939             zj_temp=zj
21940             subchap=1
21941           endif
21942        enddo
21943        enddo
21944        enddo
21945        if (subchap.eq.1) then
21946           xj=xj_temp-xi
21947           yj=yj_temp-yi
21948           zj=zj_temp-zi
21949        else
21950           xj=xj_safe-xi
21951           yj=yj_safe-yi
21952           zj=zj_safe-zi
21953        endif
21954 !       enddo
21955 !       enddo
21956        rcpm = sqrt(xj**2+yj**2+zj**2)
21957        drcp_norm(1)=xj/rcpm
21958        drcp_norm(2)=yj/rcpm
21959        drcp_norm(3)=zj/rcpm
21960        dcmag=0.0
21961        do k=1,3
21962        dcmag=dcmag+dc(k,i)**2
21963        enddo
21964        dcmag=dsqrt(dcmag)
21965        do k=1,3
21966          myd_norm(k)=dc(k,i)/dcmag
21967        enddo
21968         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
21969         drcp_norm(3)*myd_norm(3)
21970         rsecp = rcpm**2
21971         Ir = 1.0d0/rcpm
21972         Irsecp = 1.0d0/rsecp
21973         Irthrp = Irsecp/rcpm
21974         Irfourp = Irthrp/rcpm
21975         Irfiftp = Irfourp/rcpm
21976         Irsistp=Irfiftp/rcpm
21977         Irseven=Irsistp/rcpm
21978         Irtwelv=Irsistp*Irsistp
21979         Irthir=Irtwelv/rcpm
21980         sin2thet = (1-costhet*costhet)
21981         sinthet=sqrt(sin2thet)
21982         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
21983              *sin2thet
21984         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
21985              2*wvan2**6*Irsistp)
21986         ecation_prot = ecation_prot+E1+E2
21987         dE1dr = -2*costhet*wdip*Irthrp-&
21988          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
21989         dE2dr = 3*wquad1*wquad2*Irfourp-     &
21990           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
21991         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
21992         do k=1,3
21993           drdpep(k) = -drcp_norm(k)
21994           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
21995           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
21996           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
21997           dEddci(k) = dEdcos*dcosddci(k)
21998         enddo
21999         do k=1,3
22000         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22001         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22002         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22003         enddo
22004        enddo ! j
22005        enddo ! i
22006 !------------------------------------------sidechains
22007 !        do i=1,nres_molec(1)
22008         do i=ibond_start,ibond_end
22009          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22010 !         cycle
22011 !        print *,i,ecation_prot
22012         xi=(c(1,i+nres))
22013         yi=(c(2,i+nres))
22014         zi=(c(3,i+nres))
22015           xi=mod(xi,boxxsize)
22016           if (xi.lt.0) xi=xi+boxxsize
22017           yi=mod(yi,boxysize)
22018           if (yi.lt.0) yi=yi+boxysize
22019           zi=mod(zi,boxzsize)
22020           if (zi.lt.0) zi=zi+boxzsize
22021           do k=1,3
22022             cm1(k)=dc(k,i+nres)
22023           enddo
22024            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22025          do j=itmp+1,itmp+nres_molec(5)
22026            xj=c(1,j)
22027            yj=c(2,j)
22028            zj=c(3,j)
22029           xj=dmod(xj,boxxsize)
22030           if (xj.lt.0) xj=xj+boxxsize
22031           yj=dmod(yj,boxysize)
22032           if (yj.lt.0) yj=yj+boxysize
22033           zj=dmod(zj,boxzsize)
22034           if (zj.lt.0) zj=zj+boxzsize
22035       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22036       xj_safe=xj
22037       yj_safe=yj
22038       zj_safe=zj
22039       subchap=0
22040       do xshift=-1,1
22041       do yshift=-1,1
22042       do zshift=-1,1
22043           xj=xj_safe+xshift*boxxsize
22044           yj=yj_safe+yshift*boxysize
22045           zj=zj_safe+zshift*boxzsize
22046           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22047           if(dist_temp.lt.dist_init) then
22048             dist_init=dist_temp
22049             xj_temp=xj
22050             yj_temp=yj
22051             zj_temp=zj
22052             subchap=1
22053           endif
22054        enddo
22055        enddo
22056        enddo
22057        if (subchap.eq.1) then
22058           xj=xj_temp-xi
22059           yj=yj_temp-yi
22060           zj=zj_temp-zi
22061        else
22062           xj=xj_safe-xi
22063           yj=yj_safe-yi
22064           zj=zj_safe-zi
22065        endif
22066 !       enddo
22067 !       enddo
22068          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22069             if(itype(i,1).eq.16) then
22070             inum=1
22071             else
22072             inum=2
22073             endif
22074             do k=1,6
22075             vcatprm(k)=catprm(k,inum)
22076             enddo
22077             dASGL=catprm(7,inum)
22078              do k=1,3
22079                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22080                 valpha(k)=c(k,i)
22081                 vcat(k)=c(k,j)
22082               enddo
22083                       do k=1,3
22084           dx(k) = vcat(k)-vcm(k)
22085         enddo
22086         do k=1,3
22087           v1(k)=(vcm(k)-valpha(k))
22088           v2(k)=(vcat(k)-valpha(k))
22089         enddo
22090         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22091         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22092         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22093
22094 !  The weights of the energy function calculated from
22095 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22096         wh2o=78
22097         wc = vcatprm(1)
22098         wc=wc/wh2o
22099         wdip =vcatprm(2)
22100         wdip=wdip/wh2o
22101         wquad1 =vcatprm(3)
22102         wquad1=wquad1/wh2o
22103         wquad2 = vcatprm(4)
22104         wquad2=wquad2/wh2o
22105         wquad2p = 1-wquad2
22106         wvan1 = vcatprm(5)
22107         wvan2 =vcatprm(6)
22108         opt = dx(1)**2+dx(2)**2
22109         rsecp = opt+dx(3)**2
22110         rs = sqrt(rsecp)
22111         rthrp = rsecp*rs
22112         rfourp = rthrp*rs
22113         rsixp = rfourp*rsecp
22114         reight=rsixp*rsecp
22115         Ir = 1.0d0/rs
22116         Irsecp = 1/rsecp
22117         Irthrp = Irsecp/rs
22118         Irfourp = Irthrp/rs
22119         Irsixp = 1/rsixp
22120         Ireight=1/reight
22121         Irtw=Irsixp*Irsixp
22122         Irthir=Irtw/rs
22123         Irfourt=Irthir/rs
22124         opt1 = (4*rs*dx(3)*wdip)
22125         opt2 = 6*rsecp*wquad1*opt
22126         opt3 = wquad1*wquad2p*Irsixp
22127         opt4 = (wvan1*wvan2**12)
22128         opt5 = opt4*12*Irfourt
22129         opt6 = 2*wvan1*wvan2**6
22130         opt7 = 6*opt6*Ireight
22131         opt8 = wdip/v1m
22132         opt10 = wdip/v2m
22133         opt11 = (rsecp*v2m)**2
22134         opt12 = (rsecp*v1m)**2
22135         opt14 = (v1m*v2m*rsecp)**2
22136         opt15 = -wquad1/v2m**2
22137         opt16 = (rthrp*(v1m*v2m)**2)**2
22138         opt17 = (v1m**2*rthrp)**2
22139         opt18 = -wquad1/rthrp
22140         opt19 = (v1m**2*v2m**2)**2
22141         Ec = wc*Ir
22142         do k=1,3
22143           dEcCat(k) = -(dx(k)*wc)*Irthrp
22144           dEcCm(k)=(dx(k)*wc)*Irthrp
22145           dEcCalp(k)=0.0d0
22146         enddo
22147         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22148         do k=1,3
22149           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22150                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22151           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22152                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22153           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22154                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22155                       *v1dpv2)/opt14
22156         enddo
22157         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22158         do k=1,3
22159           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22160                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22161                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22162           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22163                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22164                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22165           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22166                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22167                         v1dpv2**2)/opt19
22168         enddo
22169         Equad2=wquad1*wquad2p*Irthrp
22170         do k=1,3
22171           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22172           dEquad2Cm(k)=3*dx(k)*rs*opt3
22173           dEquad2Calp(k)=0.0d0
22174         enddo
22175         Evan1=opt4*Irtw
22176         do k=1,3
22177           dEvan1Cat(k)=-dx(k)*opt5
22178           dEvan1Cm(k)=dx(k)*opt5
22179           dEvan1Calp(k)=0.0d0
22180         enddo
22181         Evan2=-opt6*Irsixp
22182         do k=1,3
22183           dEvan2Cat(k)=dx(k)*opt7
22184           dEvan2Cm(k)=-dx(k)*opt7
22185           dEvan2Calp(k)=0.0d0
22186         enddo
22187         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22188 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22189
22190         do k=1,3
22191           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22192                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22193 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22194           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22195                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22196           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22197                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22198         enddo
22199             dscmag = 0.0d0
22200             do k=1,3
22201               dscvec(k) = dc(k,i+nres)
22202               dscmag = dscmag+dscvec(k)*dscvec(k)
22203             enddo
22204             dscmag3 = dscmag
22205             dscmag = sqrt(dscmag)
22206             dscmag3 = dscmag3*dscmag
22207             constA = 1.0d0+dASGL/dscmag
22208             constB = 0.0d0
22209             do k=1,3
22210               constB = constB+dscvec(k)*dEtotalCm(k)
22211             enddo
22212             constB = constB*dASGL/dscmag3
22213             do k=1,3
22214               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22215               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22216                constA*dEtotalCm(k)-constB*dscvec(k)
22217 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22218               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22219               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22220              enddo
22221         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22222            if(itype(i,1).eq.14) then
22223             inum=3
22224             else
22225             inum=4
22226             endif
22227             do k=1,6
22228             vcatprm(k)=catprm(k,inum)
22229             enddo
22230             dASGL=catprm(7,inum)
22231              do k=1,3
22232                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22233                 valpha(k)=c(k,i)
22234                 vcat(k)=c(k,j)
22235               enddo
22236
22237         do k=1,3
22238           dx(k) = vcat(k)-vcm(k)
22239         enddo
22240         do k=1,3
22241           v1(k)=(vcm(k)-valpha(k))
22242           v2(k)=(vcat(k)-valpha(k))
22243         enddo
22244         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22245         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22246         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22247 !  The weights of the energy function calculated from
22248 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22249         wh2o=78
22250         wdip =vcatprm(2)
22251         wdip=wdip/wh2o
22252         wquad1 =vcatprm(3)
22253         wquad1=wquad1/wh2o
22254         wquad2 = vcatprm(4)
22255         wquad2=wquad2/wh2o
22256         wquad2p = 1-wquad2
22257         wvan1 = vcatprm(5)
22258         wvan2 =vcatprm(6)
22259         opt = dx(1)**2+dx(2)**2
22260         rsecp = opt+dx(3)**2
22261         rs = sqrt(rsecp)
22262         rthrp = rsecp*rs
22263         rfourp = rthrp*rs
22264         rsixp = rfourp*rsecp
22265         reight=rsixp*rsecp
22266         Ir = 1.0d0/rs
22267         Irsecp = 1/rsecp
22268         Irthrp = Irsecp/rs
22269         Irfourp = Irthrp/rs
22270         Irsixp = 1/rsixp
22271         Ireight=1/reight
22272         Irtw=Irsixp*Irsixp
22273         Irthir=Irtw/rs
22274         Irfourt=Irthir/rs
22275         opt1 = (4*rs*dx(3)*wdip)
22276         opt2 = 6*rsecp*wquad1*opt
22277         opt3 = wquad1*wquad2p*Irsixp
22278         opt4 = (wvan1*wvan2**12)
22279         opt5 = opt4*12*Irfourt
22280         opt6 = 2*wvan1*wvan2**6
22281         opt7 = 6*opt6*Ireight
22282         opt8 = wdip/v1m
22283         opt10 = wdip/v2m
22284         opt11 = (rsecp*v2m)**2
22285         opt12 = (rsecp*v1m)**2
22286         opt14 = (v1m*v2m*rsecp)**2
22287         opt15 = -wquad1/v2m**2
22288         opt16 = (rthrp*(v1m*v2m)**2)**2
22289         opt17 = (v1m**2*rthrp)**2
22290         opt18 = -wquad1/rthrp
22291         opt19 = (v1m**2*v2m**2)**2
22292         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22293         do k=1,3
22294           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22295                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22296          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22297                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22298           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22299                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22300                       *v1dpv2)/opt14
22301         enddo
22302         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22303         do k=1,3
22304           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22305                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22306                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22307           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22308                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22309                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22310           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22311                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22312                         v1dpv2**2)/opt19
22313         enddo
22314         Equad2=wquad1*wquad2p*Irthrp
22315         do k=1,3
22316           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22317           dEquad2Cm(k)=3*dx(k)*rs*opt3
22318           dEquad2Calp(k)=0.0d0
22319         enddo
22320         Evan1=opt4*Irtw
22321         do k=1,3
22322           dEvan1Cat(k)=-dx(k)*opt5
22323           dEvan1Cm(k)=dx(k)*opt5
22324           dEvan1Calp(k)=0.0d0
22325         enddo
22326         Evan2=-opt6*Irsixp
22327         do k=1,3
22328           dEvan2Cat(k)=dx(k)*opt7
22329           dEvan2Cm(k)=-dx(k)*opt7
22330           dEvan2Calp(k)=0.0d0
22331         enddo
22332          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22333         do k=1,3
22334           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22335                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22336           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22337                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22338           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22339                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22340         enddo
22341             dscmag = 0.0d0
22342             do k=1,3
22343               dscvec(k) = c(k,i+nres)-c(k,i)
22344               dscmag = dscmag+dscvec(k)*dscvec(k)
22345             enddo
22346             dscmag3 = dscmag
22347             dscmag = sqrt(dscmag)
22348             dscmag3 = dscmag3*dscmag
22349             constA = 1+dASGL/dscmag
22350             constB = 0.0d0
22351             do k=1,3
22352               constB = constB+dscvec(k)*dEtotalCm(k)
22353             enddo
22354             constB = constB*dASGL/dscmag3
22355             do k=1,3
22356               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22357               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22358                constA*dEtotalCm(k)-constB*dscvec(k)
22359               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22360               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22361              enddo
22362            else
22363             rcal = 0.0d0
22364             do k=1,3
22365               r(k) = c(k,j)-c(k,i+nres)
22366               rcal = rcal+r(k)*r(k)
22367             enddo
22368             ract=sqrt(rcal)
22369             rocal=1.5
22370             epscalc=0.2
22371             r0p=0.5*(rocal+sig0(itype(i,1)))
22372             r06 = r0p**6
22373             r012 = r06*r06
22374             Evan1=epscalc*(r012/rcal**6)
22375             Evan2=epscalc*2*(r06/rcal**3)
22376             r4 = rcal**4
22377             r7 = rcal**7
22378             do k=1,3
22379               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22380               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22381             enddo
22382             do k=1,3
22383               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22384             enddo
22385                  ecation_prot = ecation_prot+ Evan1+Evan2
22386             do  k=1,3
22387                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22388                dEtotalCm(k)
22389               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22390               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22391              enddo
22392          endif ! 13-16 residues
22393        enddo !j
22394        enddo !i
22395        return
22396        end subroutine ecat_prot
22397
22398 !----------------------------------------------------------------------------
22399 !-----------------------------------------------------------------------------
22400 !-----------------------------------------------------------------------------
22401       subroutine eprot_sc_base(escbase)
22402       use calc_data
22403 !      implicit real*8 (a-h,o-z)
22404 !      include 'DIMENSIONS'
22405 !      include 'COMMON.GEO'
22406 !      include 'COMMON.VAR'
22407 !      include 'COMMON.LOCAL'
22408 !      include 'COMMON.CHAIN'
22409 !      include 'COMMON.DERIV'
22410 !      include 'COMMON.NAMES'
22411 !      include 'COMMON.INTERACT'
22412 !      include 'COMMON.IOUNITS'
22413 !      include 'COMMON.CALC'
22414 !      include 'COMMON.CONTROL'
22415 !      include 'COMMON.SBRIDGE'
22416       logical :: lprn
22417 !el local variables
22418       integer :: iint,itypi,itypi1,itypj,subchap
22419       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22420       real(kind=8) :: evdw,sig0ij
22421       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22422                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22423                     sslipi,sslipj,faclip
22424       integer :: ii
22425       real(kind=8) :: fracinbuf
22426        real (kind=8) :: escbase
22427        real (kind=8),dimension(4):: ener
22428        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22429        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22430         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22431         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22432         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22433         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22434         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22435         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22436        real(kind=8),dimension(3,2)::chead,erhead_tail
22437        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22438        integer troll
22439        eps_out=80.0d0
22440        escbase=0.0d0
22441 !       do i=1,nres_molec(1)
22442         do i=ibond_start,ibond_end
22443         if (itype(i,1).eq.ntyp1_molec(1)) cycle
22444         itypi  = itype(i,1)
22445         dxi    = dc_norm(1,nres+i)
22446         dyi    = dc_norm(2,nres+i)
22447         dzi    = dc_norm(3,nres+i)
22448         dsci_inv = vbld_inv(i+nres)
22449         xi=c(1,nres+i)
22450         yi=c(2,nres+i)
22451         zi=c(3,nres+i)
22452         xi=mod(xi,boxxsize)
22453          if (xi.lt.0) xi=xi+boxxsize
22454         yi=mod(yi,boxysize)
22455          if (yi.lt.0) yi=yi+boxysize
22456         zi=mod(zi,boxzsize)
22457          if (zi.lt.0) zi=zi+boxzsize
22458          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22459            itypj= itype(j,2)
22460            if (itype(j,2).eq.ntyp1_molec(2))cycle
22461            xj=c(1,j+nres)
22462            yj=c(2,j+nres)
22463            zj=c(3,j+nres)
22464            xj=dmod(xj,boxxsize)
22465            if (xj.lt.0) xj=xj+boxxsize
22466            yj=dmod(yj,boxysize)
22467            if (yj.lt.0) yj=yj+boxysize
22468            zj=dmod(zj,boxzsize)
22469            if (zj.lt.0) zj=zj+boxzsize
22470           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22471           xj_safe=xj
22472           yj_safe=yj
22473           zj_safe=zj
22474           subchap=0
22475
22476           do xshift=-1,1
22477           do yshift=-1,1
22478           do zshift=-1,1
22479           xj=xj_safe+xshift*boxxsize
22480           yj=yj_safe+yshift*boxysize
22481           zj=zj_safe+zshift*boxzsize
22482           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22483           if(dist_temp.lt.dist_init) then
22484             dist_init=dist_temp
22485             xj_temp=xj
22486             yj_temp=yj
22487             zj_temp=zj
22488             subchap=1
22489           endif
22490           enddo
22491           enddo
22492           enddo
22493           if (subchap.eq.1) then
22494           xj=xj_temp-xi
22495           yj=yj_temp-yi
22496           zj=zj_temp-zi
22497           else
22498           xj=xj_safe-xi
22499           yj=yj_safe-yi
22500           zj=zj_safe-zi
22501           endif
22502           dxj = dc_norm( 1, nres+j )
22503           dyj = dc_norm( 2, nres+j )
22504           dzj = dc_norm( 3, nres+j )
22505 !          print *,i,j,itypi,itypj
22506           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
22507           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
22508 !          d1i=0.0d0
22509 !          d1j=0.0d0
22510 !          BetaT = 1.0d0 / (298.0d0 * Rb)
22511 ! Gay-berne var's
22512           sig0ij = sigma_scbase( itypi,itypj )
22513           chi1   = chi_scbase( itypi, itypj,1 )
22514           chi2   = chi_scbase( itypi, itypj,2 )
22515 !          chi1=0.0d0
22516 !          chi2=0.0d0
22517           chi12  = chi1 * chi2
22518           chip1  = chipp_scbase( itypi, itypj,1 )
22519           chip2  = chipp_scbase( itypi, itypj,2 )
22520 !          chip1=0.0d0
22521 !          chip2=0.0d0
22522           chip12 = chip1 * chip2
22523 ! not used by momo potential, but needed by sc_angular which is shared
22524 ! by all energy_potential subroutines
22525           alf1   = 0.0d0
22526           alf2   = 0.0d0
22527           alf12  = 0.0d0
22528           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
22529 !       a12sq = a12sq * a12sq
22530 ! charge of amino acid itypi is...
22531           chis1 = chis_scbase(itypi,itypj,1)
22532           chis2 = chis_scbase(itypi,itypj,2)
22533           chis12 = chis1 * chis2
22534           sig1 = sigmap1_scbase(itypi,itypj)
22535           sig2 = sigmap2_scbase(itypi,itypj)
22536 !       write (*,*) "sig1 = ", sig1
22537 !       write (*,*) "sig2 = ", sig2
22538 ! alpha factors from Fcav/Gcav
22539           b1 = alphasur_scbase(1,itypi,itypj)
22540 !          b1=0.0d0
22541           b2 = alphasur_scbase(2,itypi,itypj)
22542           b3 = alphasur_scbase(3,itypi,itypj)
22543           b4 = alphasur_scbase(4,itypi,itypj)
22544 ! used to determine whether we want to do quadrupole calculations
22545 ! used by Fgb
22546        eps_in = epsintab_scbase(itypi,itypj)
22547        if (eps_in.eq.0.0) eps_in=1.0
22548        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22549 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
22550 !-------------------------------------------------------------------
22551 ! tail location and distance calculations
22552        DO k = 1,3
22553 ! location of polar head is computed by taking hydrophobic centre
22554 ! and moving by a d1 * dc_norm vector
22555 ! see unres publications for very informative images
22556         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
22557         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
22558 ! distance
22559 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22560 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22561         Rhead_distance(k) = chead(k,2) - chead(k,1)
22562        END DO
22563 ! pitagoras (root of sum of squares)
22564        Rhead = dsqrt( &
22565           (Rhead_distance(1)*Rhead_distance(1)) &
22566         + (Rhead_distance(2)*Rhead_distance(2)) &
22567         + (Rhead_distance(3)*Rhead_distance(3)))
22568 !-------------------------------------------------------------------
22569 ! zero everything that should be zero'ed
22570        evdwij = 0.0d0
22571        ECL = 0.0d0
22572        Elj = 0.0d0
22573        Equad = 0.0d0
22574        Epol = 0.0d0
22575        Fcav=0.0d0
22576        eheadtail = 0.0d0
22577        dGCLdOM1 = 0.0d0
22578        dGCLdOM2 = 0.0d0
22579        dGCLdOM12 = 0.0d0
22580        dPOLdOM1 = 0.0d0
22581        dPOLdOM2 = 0.0d0
22582           Fcav = 0.0d0
22583           dFdR = 0.0d0
22584           dCAVdOM1  = 0.0d0
22585           dCAVdOM2  = 0.0d0
22586           dCAVdOM12 = 0.0d0
22587           dscj_inv = vbld_inv(j+nres)
22588 !          print *,i,j,dscj_inv,dsci_inv
22589 ! rij holds 1/(distance of Calpha atoms)
22590           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22591           rij  = dsqrt(rrij)
22592 !----------------------------
22593           CALL sc_angular
22594 ! this should be in elgrad_init but om's are calculated by sc_angular
22595 ! which in turn is used by older potentials
22596 ! om = omega, sqom = om^2
22597           sqom1  = om1 * om1
22598           sqom2  = om2 * om2
22599           sqom12 = om12 * om12
22600
22601 ! now we calculate EGB - Gey-Berne
22602 ! It will be summed up in evdwij and saved in evdw
22603           sigsq     = 1.0D0  / sigsq
22604           sig       = sig0ij * dsqrt(sigsq)
22605 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22606           rij_shift = 1.0/rij - sig + sig0ij
22607           IF (rij_shift.le.0.0D0) THEN
22608            evdw = 1.0D20
22609            RETURN
22610           END IF
22611           sigder = -sig * sigsq
22612           rij_shift = 1.0D0 / rij_shift
22613           fac       = rij_shift**expon
22614           c1        = fac  * fac * aa_scbase(itypi,itypj)
22615 !          c1        = 0.0d0
22616           c2        = fac  * bb_scbase(itypi,itypj)
22617 !          c2        = 0.0d0
22618           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22619           eps2der   = eps3rt * evdwij
22620           eps3der   = eps2rt * evdwij
22621 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22622           evdwij    = eps2rt * eps3rt * evdwij
22623           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22624           fac    = -expon * (c1 + evdwij) * rij_shift
22625           sigder = fac * sigder
22626 !          fac    = rij * fac
22627 ! Calculate distance derivative
22628           gg(1) =  fac
22629           gg(2) =  fac
22630           gg(3) =  fac
22631 !          if (b2.gt.0.0) then
22632           fac = chis1 * sqom1 + chis2 * sqom2 &
22633           - 2.0d0 * chis12 * om1 * om2 * om12
22634 ! we will use pom later in Gcav, so dont mess with it!
22635           pom = 1.0d0 - chis1 * chis2 * sqom12
22636           Lambf = (1.0d0 - (fac / pom))
22637           Lambf = dsqrt(Lambf)
22638           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22639 !       write (*,*) "sparrow = ", sparrow
22640           Chif = 1.0d0/rij * sparrow
22641           ChiLambf = Chif * Lambf
22642           eagle = dsqrt(ChiLambf)
22643           bat = ChiLambf ** 11.0d0
22644           top = b1 * ( eagle + b2 * ChiLambf - b3 )
22645           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
22646           botsq = bot * bot
22647           Fcav = top / bot
22648 !          print *,i,j,Fcav
22649           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
22650           dbot = 12.0d0 * b4 * bat * Lambf
22651           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22652 !       dFdR = 0.0d0
22653 !      write (*,*) "dFcav/dR = ", dFdR
22654           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
22655           dbot = 12.0d0 * b4 * bat * Chif
22656           eagle = Lambf * pom
22657           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22658           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22659           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22660               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22661
22662           dFdL = ((dtop * bot - top * dbot) / botsq)
22663 !       dFdL = 0.0d0
22664           dCAVdOM1  = dFdL * ( dFdOM1 )
22665           dCAVdOM2  = dFdL * ( dFdOM2 )
22666           dCAVdOM12 = dFdL * ( dFdOM12 )
22667
22668           ertail(1) = xj*rij
22669           ertail(2) = yj*rij
22670           ertail(3) = zj*rij
22671 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
22672 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
22673 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
22674 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
22675 !           print *,"EOMY",eom1,eom2,eom12
22676 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22677 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
22678 ! here dtail=0.0
22679 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
22680 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22681        DO k = 1, 3
22682 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22683 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22684         pom = ertail(k)
22685 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22686         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22687                   - (( dFdR + gg(k) ) * pom)
22688 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22689 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22690 !     &             - ( dFdR * pom )
22691         pom = ertail(k)
22692 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22693         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22694                   + (( dFdR + gg(k) ) * pom)
22695 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22696 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22697 !c!     &             + ( dFdR * pom )
22698
22699         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22700                   - (( dFdR + gg(k) ) * ertail(k))
22701 !c!     &             - ( dFdR * ertail(k))
22702
22703         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22704                   + (( dFdR + gg(k) ) * ertail(k))
22705 !c!     &             + ( dFdR * ertail(k))
22706
22707         gg(k) = 0.0d0
22708 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22709 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22710       END DO
22711
22712 !          else
22713
22714 !          endif
22715 !Now dipole-dipole
22716          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
22717        w1 = wdipdip_scbase(1,itypi,itypj)
22718        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
22719        w3 = wdipdip_scbase(2,itypi,itypj)
22720 !c!-------------------------------------------------------------------
22721 !c! ECL
22722        fac = (om12 - 3.0d0 * om1 * om2)
22723        c1 = (w1 / (Rhead**3.0d0)) * fac
22724        c2 = (w2 / Rhead ** 6.0d0)  &
22725          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22726        c3= (w3/ Rhead ** 6.0d0)  &
22727          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22728        ECL = c1 - c2 + c3
22729 !c!       write (*,*) "w1 = ", w1
22730 !c!       write (*,*) "w2 = ", w2
22731 !c!       write (*,*) "om1 = ", om1
22732 !c!       write (*,*) "om2 = ", om2
22733 !c!       write (*,*) "om12 = ", om12
22734 !c!       write (*,*) "fac = ", fac
22735 !c!       write (*,*) "c1 = ", c1
22736 !c!       write (*,*) "c2 = ", c2
22737 !c!       write (*,*) "Ecl = ", Ecl
22738 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
22739 !c!       write (*,*) "c2_2 = ",
22740 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22741 !c!-------------------------------------------------------------------
22742 !c! dervative of ECL is GCL...
22743 !c! dECL/dr
22744        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
22745        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
22746          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
22747        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
22748          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22749        dGCLdR = c1 - c2 + c3
22750 !c! dECL/dom1
22751        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
22752        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22753          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
22754        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
22755        dGCLdOM1 = c1 - c2 + c3
22756 !c! dECL/dom2
22757        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
22758        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22759          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
22760        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
22761        dGCLdOM2 = c1 - c2 + c3
22762 !c! dECL/dom12
22763        c1 = w1 / (Rhead ** 3.0d0)
22764        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
22765        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
22766        dGCLdOM12 = c1 - c2 + c3
22767        DO k= 1, 3
22768         erhead(k) = Rhead_distance(k)/Rhead
22769        END DO
22770        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22771        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22772        facd1 = d1i * vbld_inv(i+nres)
22773        facd2 = d1j * vbld_inv(j+nres)
22774        DO k = 1, 3
22775
22776         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22777         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22778                   - dGCLdR * pom
22779         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22780         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22781                   + dGCLdR * pom
22782
22783         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22784                   - dGCLdR * erhead(k)
22785         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22786                   + dGCLdR * erhead(k)
22787        END DO
22788        endif
22789 !now charge with dipole eg. ARG-dG
22790        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
22791       alphapol1 = alphapol_scbase(itypi,itypj)
22792        w1        = wqdip_scbase(1,itypi,itypj)
22793        w2        = wqdip_scbase(2,itypi,itypj)
22794 !       w1=0.0d0
22795 !       w2=0.0d0
22796 !       pis       = sig0head_scbase(itypi,itypj)
22797 !       eps_head   = epshead_scbase(itypi,itypj)
22798 !c!-------------------------------------------------------------------
22799 !c! R1 - distance between head of ith side chain and tail of jth sidechain
22800        R1 = 0.0d0
22801        DO k = 1, 3
22802 !c! Calculate head-to-tail distances tail is center of side-chain
22803         R1=R1+(c(k,j+nres)-chead(k,1))**2
22804        END DO
22805 !c! Pitagoras
22806        R1 = dsqrt(R1)
22807
22808 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
22809 !c!     &        +dhead(1,1,itypi,itypj))**2))
22810 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
22811 !c!     &        +dhead(2,1,itypi,itypj))**2))
22812
22813 !c!-------------------------------------------------------------------
22814 !c! ecl
22815        sparrow  = w1  *  om1
22816        hawk     = w2 *  (1.0d0 - sqom2)
22817        Ecl = sparrow / Rhead**2.0d0 &
22818            - hawk    / Rhead**4.0d0
22819 !c!-------------------------------------------------------------------
22820 !c! derivative of ecl is Gcl
22821 !c! dF/dr part
22822        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
22823                 + 4.0d0 * hawk    / Rhead**5.0d0
22824 !c! dF/dom1
22825        dGCLdOM1 = (w1) / (Rhead**2.0d0)
22826 !c! dF/dom2
22827        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
22828 !c--------------------------------------------------------------------
22829 !c Polarization energy
22830 !c Epol
22831        MomoFac1 = (1.0d0 - chi1 * sqom2)
22832        RR1  = R1 * R1 / MomoFac1
22833        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
22834        fgb1 = sqrt( RR1 + a12sq * ee1)
22835 !       eps_inout_fac=0.0d0
22836        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
22837 ! derivative of Epol is Gpol...
22838        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
22839                 / (fgb1 ** 5.0d0)
22840        dFGBdR1 = ( (R1 / MomoFac1) &
22841              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
22842              / ( 2.0d0 * fgb1 )
22843        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
22844                * (2.0d0 - 0.5d0 * ee1) ) &
22845                / (2.0d0 * fgb1)
22846        dPOLdR1 = dPOLdFGB1 * dFGBdR1
22847 !       dPOLdR1 = 0.0d0
22848        dPOLdOM1 = 0.0d0
22849        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
22850        DO k = 1, 3
22851         erhead(k) = Rhead_distance(k)/Rhead
22852         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
22853        END DO
22854
22855        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22856        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22857        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
22858 !       bat=0.0d0
22859        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
22860        facd1 = d1i * vbld_inv(i+nres)
22861        facd2 = d1j * vbld_inv(j+nres)
22862 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22863
22864        DO k = 1, 3
22865         hawk = (erhead_tail(k,1) + &
22866         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
22867 !        facd1=0.0d0
22868 !        facd2=0.0d0
22869         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22870         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
22871                    - dGCLdR * pom &
22872                    - dPOLdR1 *  (erhead_tail(k,1))
22873 !     &             - dGLJdR * pom
22874
22875         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22876         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
22877                    + dGCLdR * pom  &
22878                    + dPOLdR1 * (erhead_tail(k,1))
22879 !     &             + dGLJdR * pom
22880
22881
22882         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
22883                   - dGCLdR * erhead(k) &
22884                   - dPOLdR1 * erhead_tail(k,1)
22885 !     &             - dGLJdR * erhead(k)
22886
22887         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
22888                   + dGCLdR * erhead(k)  &
22889                   + dPOLdR1 * erhead_tail(k,1)
22890 !     &             + dGLJdR * erhead(k)
22891
22892        END DO
22893        endif
22894 !       print *,i,j,evdwij,epol,Fcav,ECL
22895        escbase=escbase+evdwij+epol+Fcav+ECL
22896        call sc_grad_scbase
22897          enddo
22898       enddo
22899
22900       return
22901       end subroutine eprot_sc_base
22902       SUBROUTINE sc_grad_scbase
22903       use calc_data
22904
22905        real (kind=8) :: dcosom1(3),dcosom2(3)
22906        eom1  =    &
22907               eps2der * eps2rt_om1   &
22908             - 2.0D0 * alf1 * eps3der &
22909             + sigder * sigsq_om1     &
22910             + dCAVdOM1               &
22911             + dGCLdOM1               &
22912             + dPOLdOM1
22913
22914        eom2  =  &
22915               eps2der * eps2rt_om2   &
22916             + 2.0D0 * alf2 * eps3der &
22917             + sigder * sigsq_om2     &
22918             + dCAVdOM2               &
22919             + dGCLdOM2               &
22920             + dPOLdOM2
22921
22922        eom12 =    &
22923               evdwij  * eps1_om12     &
22924             + eps2der * eps2rt_om12   &
22925             - 2.0D0 * alf12 * eps3der &
22926             + sigder *sigsq_om12      &
22927             + dCAVdOM12               &
22928             + dGCLdOM12
22929
22930 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
22931 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
22932 !               gg(1),gg(2),"rozne"
22933        DO k = 1, 3
22934         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
22935         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
22936         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
22937         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
22938                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22939                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22940         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
22941                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22942                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22943         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
22944         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
22945        END DO
22946        RETURN
22947       END SUBROUTINE sc_grad_scbase
22948
22949
22950       subroutine epep_sc_base(epepbase)
22951       use calc_data
22952       logical :: lprn
22953 !el local variables
22954       integer :: iint,itypi,itypi1,itypj,subchap
22955       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22956       real(kind=8) :: evdw,sig0ij
22957       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22958                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22959                     sslipi,sslipj,faclip
22960       integer :: ii
22961       real(kind=8) :: fracinbuf
22962        real (kind=8) :: epepbase
22963        real (kind=8),dimension(4):: ener
22964        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22965        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22966         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22967         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22968         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22969         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22970         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22971         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22972        real(kind=8),dimension(3,2)::chead,erhead_tail
22973        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22974        integer troll
22975        eps_out=80.0d0
22976        epepbase=0.0d0
22977 !       do i=1,nres_molec(1)-1
22978         do i=ibond_start,ibond_end
22979         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
22980 !C        itypi  = itype(i,1)
22981         dxi    = dc_norm(1,i)
22982         dyi    = dc_norm(2,i)
22983         dzi    = dc_norm(3,i)
22984 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
22985         dsci_inv = vbld_inv(i+1)/2.0
22986         xi=(c(1,i)+c(1,i+1))/2.0
22987         yi=(c(2,i)+c(2,i+1))/2.0
22988         zi=(c(3,i)+c(3,i+1))/2.0
22989         xi=mod(xi,boxxsize)
22990          if (xi.lt.0) xi=xi+boxxsize
22991         yi=mod(yi,boxysize)
22992          if (yi.lt.0) yi=yi+boxysize
22993         zi=mod(zi,boxzsize)
22994          if (zi.lt.0) zi=zi+boxzsize
22995          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22996            itypj= itype(j,2)
22997            if (itype(j,2).eq.ntyp1_molec(2))cycle
22998            xj=c(1,j+nres)
22999            yj=c(2,j+nres)
23000            zj=c(3,j+nres)
23001            xj=dmod(xj,boxxsize)
23002            if (xj.lt.0) xj=xj+boxxsize
23003            yj=dmod(yj,boxysize)
23004            if (yj.lt.0) yj=yj+boxysize
23005            zj=dmod(zj,boxzsize)
23006            if (zj.lt.0) zj=zj+boxzsize
23007           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23008           xj_safe=xj
23009           yj_safe=yj
23010           zj_safe=zj
23011           subchap=0
23012
23013           do xshift=-1,1
23014           do yshift=-1,1
23015           do zshift=-1,1
23016           xj=xj_safe+xshift*boxxsize
23017           yj=yj_safe+yshift*boxysize
23018           zj=zj_safe+zshift*boxzsize
23019           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23020           if(dist_temp.lt.dist_init) then
23021             dist_init=dist_temp
23022             xj_temp=xj
23023             yj_temp=yj
23024             zj_temp=zj
23025             subchap=1
23026           endif
23027           enddo
23028           enddo
23029           enddo
23030           if (subchap.eq.1) then
23031           xj=xj_temp-xi
23032           yj=yj_temp-yi
23033           zj=zj_temp-zi
23034           else
23035           xj=xj_safe-xi
23036           yj=yj_safe-yi
23037           zj=zj_safe-zi
23038           endif
23039           dxj = dc_norm( 1, nres+j )
23040           dyj = dc_norm( 2, nres+j )
23041           dzj = dc_norm( 3, nres+j )
23042 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23043 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23044
23045 ! Gay-berne var's
23046           sig0ij = sigma_pepbase(itypj )
23047           chi1   = chi_pepbase(itypj,1 )
23048           chi2   = chi_pepbase(itypj,2 )
23049 !          chi1=0.0d0
23050 !          chi2=0.0d0
23051           chi12  = chi1 * chi2
23052           chip1  = chipp_pepbase(itypj,1 )
23053           chip2  = chipp_pepbase(itypj,2 )
23054 !          chip1=0.0d0
23055 !          chip2=0.0d0
23056           chip12 = chip1 * chip2
23057           chis1 = chis_pepbase(itypj,1)
23058           chis2 = chis_pepbase(itypj,2)
23059           chis12 = chis1 * chis2
23060           sig1 = sigmap1_pepbase(itypj)
23061           sig2 = sigmap2_pepbase(itypj)
23062 !       write (*,*) "sig1 = ", sig1
23063 !       write (*,*) "sig2 = ", sig2
23064        DO k = 1,3
23065 ! location of polar head is computed by taking hydrophobic centre
23066 ! and moving by a d1 * dc_norm vector
23067 ! see unres publications for very informative images
23068         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23069 ! + d1i * dc_norm(k, i+nres)
23070         chead(k,2) = c(k, j+nres)
23071 ! + d1j * dc_norm(k, j+nres)
23072 ! distance
23073 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23074 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23075         Rhead_distance(k) = chead(k,2) - chead(k,1)
23076 !        print *,gvdwc_pepbase(k,i)
23077
23078        END DO
23079        Rhead = dsqrt( &
23080           (Rhead_distance(1)*Rhead_distance(1)) &
23081         + (Rhead_distance(2)*Rhead_distance(2)) &
23082         + (Rhead_distance(3)*Rhead_distance(3)))
23083
23084 ! alpha factors from Fcav/Gcav
23085           b1 = alphasur_pepbase(1,itypj)
23086 !          b1=0.0d0
23087           b2 = alphasur_pepbase(2,itypj)
23088           b3 = alphasur_pepbase(3,itypj)
23089           b4 = alphasur_pepbase(4,itypj)
23090           alf1   = 0.0d0
23091           alf2   = 0.0d0
23092           alf12  = 0.0d0
23093           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23094 !          print *,i,j,rrij
23095           rij  = dsqrt(rrij)
23096 !----------------------------
23097        evdwij = 0.0d0
23098        ECL = 0.0d0
23099        Elj = 0.0d0
23100        Equad = 0.0d0
23101        Epol = 0.0d0
23102        Fcav=0.0d0
23103        eheadtail = 0.0d0
23104        dGCLdOM1 = 0.0d0
23105        dGCLdOM2 = 0.0d0
23106        dGCLdOM12 = 0.0d0
23107        dPOLdOM1 = 0.0d0
23108        dPOLdOM2 = 0.0d0
23109           Fcav = 0.0d0
23110           dFdR = 0.0d0
23111           dCAVdOM1  = 0.0d0
23112           dCAVdOM2  = 0.0d0
23113           dCAVdOM12 = 0.0d0
23114           dscj_inv = vbld_inv(j+nres)
23115           CALL sc_angular
23116 ! this should be in elgrad_init but om's are calculated by sc_angular
23117 ! which in turn is used by older potentials
23118 ! om = omega, sqom = om^2
23119           sqom1  = om1 * om1
23120           sqom2  = om2 * om2
23121           sqom12 = om12 * om12
23122
23123 ! now we calculate EGB - Gey-Berne
23124 ! It will be summed up in evdwij and saved in evdw
23125           sigsq     = 1.0D0  / sigsq
23126           sig       = sig0ij * dsqrt(sigsq)
23127           rij_shift = 1.0/rij - sig + sig0ij
23128           IF (rij_shift.le.0.0D0) THEN
23129            evdw = 1.0D20
23130            RETURN
23131           END IF
23132           sigder = -sig * sigsq
23133           rij_shift = 1.0D0 / rij_shift
23134           fac       = rij_shift**expon
23135           c1        = fac  * fac * aa_pepbase(itypj)
23136 !          c1        = 0.0d0
23137           c2        = fac  * bb_pepbase(itypj)
23138 !          c2        = 0.0d0
23139           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23140           eps2der   = eps3rt * evdwij
23141           eps3der   = eps2rt * evdwij
23142 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23143           evdwij    = eps2rt * eps3rt * evdwij
23144           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23145           fac    = -expon * (c1 + evdwij) * rij_shift
23146           sigder = fac * sigder
23147 !          fac    = rij * fac
23148 ! Calculate distance derivative
23149           gg(1) =  fac
23150           gg(2) =  fac
23151           gg(3) =  fac
23152           fac = chis1 * sqom1 + chis2 * sqom2 &
23153           - 2.0d0 * chis12 * om1 * om2 * om12
23154 ! we will use pom later in Gcav, so dont mess with it!
23155           pom = 1.0d0 - chis1 * chis2 * sqom12
23156           Lambf = (1.0d0 - (fac / pom))
23157           Lambf = dsqrt(Lambf)
23158           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23159 !       write (*,*) "sparrow = ", sparrow
23160           Chif = 1.0d0/rij * sparrow
23161           ChiLambf = Chif * Lambf
23162           eagle = dsqrt(ChiLambf)
23163           bat = ChiLambf ** 11.0d0
23164           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23165           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23166           botsq = bot * bot
23167           Fcav = top / bot
23168 !          print *,i,j,Fcav
23169           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23170           dbot = 12.0d0 * b4 * bat * Lambf
23171           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23172 !       dFdR = 0.0d0
23173 !      write (*,*) "dFcav/dR = ", dFdR
23174           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23175           dbot = 12.0d0 * b4 * bat * Chif
23176           eagle = Lambf * pom
23177           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23178           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23179           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23180               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23181
23182           dFdL = ((dtop * bot - top * dbot) / botsq)
23183 !       dFdL = 0.0d0
23184           dCAVdOM1  = dFdL * ( dFdOM1 )
23185           dCAVdOM2  = dFdL * ( dFdOM2 )
23186           dCAVdOM12 = dFdL * ( dFdOM12 )
23187
23188           ertail(1) = xj*rij
23189           ertail(2) = yj*rij
23190           ertail(3) = zj*rij
23191        DO k = 1, 3
23192 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23193 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23194         pom = ertail(k)
23195 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23196         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23197                   - (( dFdR + gg(k) ) * pom)/2.0
23198 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
23199 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23200 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23201 !     &             - ( dFdR * pom )
23202         pom = ertail(k)
23203 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23204         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23205                   + (( dFdR + gg(k) ) * pom)
23206 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23207 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23208 !c!     &             + ( dFdR * pom )
23209
23210         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23211                   - (( dFdR + gg(k) ) * ertail(k))/2.0
23212 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
23213
23214 !c!     &             - ( dFdR * ertail(k))
23215
23216         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23217                   + (( dFdR + gg(k) ) * ertail(k))
23218 !c!     &             + ( dFdR * ertail(k))
23219
23220         gg(k) = 0.0d0
23221 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23222 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23223       END DO
23224
23225
23226        w1 = wdipdip_pepbase(1,itypj)
23227        w2 = -wdipdip_pepbase(3,itypj)/2.0
23228        w3 = wdipdip_pepbase(2,itypj)
23229 !       w1=0.0d0
23230 !       w2=0.0d0
23231 !c!-------------------------------------------------------------------
23232 !c! ECL
23233 !       w3=0.0d0
23234        fac = (om12 - 3.0d0 * om1 * om2)
23235        c1 = (w1 / (Rhead**3.0d0)) * fac
23236        c2 = (w2 / Rhead ** 6.0d0)  &
23237          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23238        c3= (w3/ Rhead ** 6.0d0)  &
23239          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23240
23241        ECL = c1 - c2 + c3
23242
23243        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23244        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23245          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23246        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23247          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23248
23249        dGCLdR = c1 - c2 + c3
23250 !c! dECL/dom1
23251        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23252        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23253          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23254        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23255        dGCLdOM1 = c1 - c2 + c3
23256 !c! dECL/dom2
23257        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23258        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23259          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23260        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23261
23262        dGCLdOM2 = c1 - c2 + c3
23263 !c! dECL/dom12
23264        c1 = w1 / (Rhead ** 3.0d0)
23265        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23266        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23267        dGCLdOM12 = c1 - c2 + c3
23268        DO k= 1, 3
23269         erhead(k) = Rhead_distance(k)/Rhead
23270        END DO
23271        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23272        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23273 !       facd1 = d1 * vbld_inv(i+nres)
23274 !       facd2 = d2 * vbld_inv(j+nres)
23275        DO k = 1, 3
23276
23277 !        pom = erhead(k)
23278 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23279 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
23280 !                  - dGCLdR * pom
23281         pom = erhead(k)
23282 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23283         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23284                   + dGCLdR * pom
23285
23286         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23287                   - dGCLdR * erhead(k)/2.0d0
23288 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23289         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23290                   - dGCLdR * erhead(k)/2.0d0
23291 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23292         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23293                   + dGCLdR * erhead(k)
23294        END DO
23295 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
23296        epepbase=epepbase+evdwij+Fcav+ECL
23297        call sc_grad_pepbase
23298        enddo
23299        enddo
23300       END SUBROUTINE epep_sc_base
23301       SUBROUTINE sc_grad_pepbase
23302       use calc_data
23303
23304        real (kind=8) :: dcosom1(3),dcosom2(3)
23305        eom1  =    &
23306               eps2der * eps2rt_om1   &
23307             - 2.0D0 * alf1 * eps3der &
23308             + sigder * sigsq_om1     &
23309             + dCAVdOM1               &
23310             + dGCLdOM1               &
23311             + dPOLdOM1
23312
23313        eom2  =  &
23314               eps2der * eps2rt_om2   &
23315             + 2.0D0 * alf2 * eps3der &
23316             + sigder * sigsq_om2     &
23317             + dCAVdOM2               &
23318             + dGCLdOM2               &
23319             + dPOLdOM2
23320
23321        eom12 =    &
23322               evdwij  * eps1_om12     &
23323             + eps2der * eps2rt_om12   &
23324             - 2.0D0 * alf12 * eps3der &
23325             + sigder *sigsq_om12      &
23326             + dCAVdOM12               &
23327             + dGCLdOM12
23328 !        om12=0.0
23329 !        eom12=0.0
23330 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23331 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
23332 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23333 !                 *dsci_inv*2.0
23334 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23335 !               gg(1),gg(2),"rozne"
23336        DO k = 1, 3
23337         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
23338         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23339         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23340         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
23341                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23342                  *dsci_inv*2.0 &
23343                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23344         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
23345                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
23346                  *dsci_inv*2.0 &
23347                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23348 !         print *,eom12,eom2,om12,om2
23349 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23350 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23351         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
23352                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23353                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23354         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
23355        END DO
23356        RETURN
23357       END SUBROUTINE sc_grad_pepbase
23358       subroutine eprot_sc_phosphate(escpho)
23359       use calc_data
23360 !      implicit real*8 (a-h,o-z)
23361 !      include 'DIMENSIONS'
23362 !      include 'COMMON.GEO'
23363 !      include 'COMMON.VAR'
23364 !      include 'COMMON.LOCAL'
23365 !      include 'COMMON.CHAIN'
23366 !      include 'COMMON.DERIV'
23367 !      include 'COMMON.NAMES'
23368 !      include 'COMMON.INTERACT'
23369 !      include 'COMMON.IOUNITS'
23370 !      include 'COMMON.CALC'
23371 !      include 'COMMON.CONTROL'
23372 !      include 'COMMON.SBRIDGE'
23373       logical :: lprn
23374 !el local variables
23375       integer :: iint,itypi,itypi1,itypj,subchap
23376       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23377       real(kind=8) :: evdw,sig0ij
23378       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23379                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23380                     sslipi,sslipj,faclip,alpha_sco
23381       integer :: ii
23382       real(kind=8) :: fracinbuf
23383        real (kind=8) :: escpho
23384        real (kind=8),dimension(4):: ener
23385        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23386        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23387         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23388         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23389         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23390         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23391         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23392         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23393        real(kind=8),dimension(3,2)::chead,erhead_tail
23394        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23395        integer troll
23396        eps_out=80.0d0
23397        escpho=0.0d0
23398 !       do i=1,nres_molec(1)
23399         do i=ibond_start,ibond_end
23400         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23401         itypi  = itype(i,1)
23402         dxi    = dc_norm(1,nres+i)
23403         dyi    = dc_norm(2,nres+i)
23404         dzi    = dc_norm(3,nres+i)
23405         dsci_inv = vbld_inv(i+nres)
23406         xi=c(1,nres+i)
23407         yi=c(2,nres+i)
23408         zi=c(3,nres+i)
23409         xi=mod(xi,boxxsize)
23410          if (xi.lt.0) xi=xi+boxxsize
23411         yi=mod(yi,boxysize)
23412          if (yi.lt.0) yi=yi+boxysize
23413         zi=mod(zi,boxzsize)
23414          if (zi.lt.0) zi=zi+boxzsize
23415          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23416            itypj= itype(j,2)
23417            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23418             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23419            xj=(c(1,j)+c(1,j+1))/2.0
23420            yj=(c(2,j)+c(2,j+1))/2.0
23421            zj=(c(3,j)+c(3,j+1))/2.0
23422            xj=dmod(xj,boxxsize)
23423            if (xj.lt.0) xj=xj+boxxsize
23424            yj=dmod(yj,boxysize)
23425            if (yj.lt.0) yj=yj+boxysize
23426            zj=dmod(zj,boxzsize)
23427            if (zj.lt.0) zj=zj+boxzsize
23428           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23429           xj_safe=xj
23430           yj_safe=yj
23431           zj_safe=zj
23432           subchap=0
23433           do xshift=-1,1
23434           do yshift=-1,1
23435           do zshift=-1,1
23436           xj=xj_safe+xshift*boxxsize
23437           yj=yj_safe+yshift*boxysize
23438           zj=zj_safe+zshift*boxzsize
23439           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23440           if(dist_temp.lt.dist_init) then
23441             dist_init=dist_temp
23442             xj_temp=xj
23443             yj_temp=yj
23444             zj_temp=zj
23445             subchap=1
23446           endif
23447           enddo
23448           enddo
23449           enddo
23450           if (subchap.eq.1) then
23451           xj=xj_temp-xi
23452           yj=yj_temp-yi
23453           zj=zj_temp-zi
23454           else
23455           xj=xj_safe-xi
23456           yj=yj_safe-yi
23457           zj=zj_safe-zi
23458           endif
23459           dxj = dc_norm( 1,j )
23460           dyj = dc_norm( 2,j )
23461           dzj = dc_norm( 3,j )
23462           dscj_inv = vbld_inv(j+1)
23463
23464 ! Gay-berne var's
23465           sig0ij = sigma_scpho(itypi )
23466           chi1   = chi_scpho(itypi,1 )
23467           chi2   = chi_scpho(itypi,2 )
23468 !          chi1=0.0d0
23469 !          chi2=0.0d0
23470           chi12  = chi1 * chi2
23471           chip1  = chipp_scpho(itypi,1 )
23472           chip2  = chipp_scpho(itypi,2 )
23473 !          chip1=0.0d0
23474 !          chip2=0.0d0
23475           chip12 = chip1 * chip2
23476           chis1 = chis_scpho(itypi,1)
23477           chis2 = chis_scpho(itypi,2)
23478           chis12 = chis1 * chis2
23479           sig1 = sigmap1_scpho(itypi)
23480           sig2 = sigmap2_scpho(itypi)
23481 !       write (*,*) "sig1 = ", sig1
23482 !       write (*,*) "sig1 = ", sig1
23483 !       write (*,*) "sig2 = ", sig2
23484 ! alpha factors from Fcav/Gcav
23485           alf1   = 0.0d0
23486           alf2   = 0.0d0
23487           alf12  = 0.0d0
23488           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
23489
23490           b1 = alphasur_scpho(1,itypi)
23491 !          b1=0.0d0
23492           b2 = alphasur_scpho(2,itypi)
23493           b3 = alphasur_scpho(3,itypi)
23494           b4 = alphasur_scpho(4,itypi)
23495 ! used to determine whether we want to do quadrupole calculations
23496 ! used by Fgb
23497        eps_in = epsintab_scpho(itypi)
23498        if (eps_in.eq.0.0) eps_in=1.0
23499        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23500 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23501 !-------------------------------------------------------------------
23502 ! tail location and distance calculations
23503           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
23504           d1j = 0.0
23505        DO k = 1,3
23506 ! location of polar head is computed by taking hydrophobic centre
23507 ! and moving by a d1 * dc_norm vector
23508 ! see unres publications for very informative images
23509         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23510         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
23511 ! distance
23512 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23513 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23514         Rhead_distance(k) = chead(k,2) - chead(k,1)
23515        END DO
23516 ! pitagoras (root of sum of squares)
23517        Rhead = dsqrt( &
23518           (Rhead_distance(1)*Rhead_distance(1)) &
23519         + (Rhead_distance(2)*Rhead_distance(2)) &
23520         + (Rhead_distance(3)*Rhead_distance(3)))
23521        Rhead_sq=Rhead**2.0
23522 !-------------------------------------------------------------------
23523 ! zero everything that should be zero'ed
23524        evdwij = 0.0d0
23525        ECL = 0.0d0
23526        Elj = 0.0d0
23527        Equad = 0.0d0
23528        Epol = 0.0d0
23529        Fcav=0.0d0
23530        eheadtail = 0.0d0
23531        dGCLdR=0.0d0
23532        dGCLdOM1 = 0.0d0
23533        dGCLdOM2 = 0.0d0
23534        dGCLdOM12 = 0.0d0
23535        dPOLdOM1 = 0.0d0
23536        dPOLdOM2 = 0.0d0
23537           Fcav = 0.0d0
23538           dFdR = 0.0d0
23539           dCAVdOM1  = 0.0d0
23540           dCAVdOM2  = 0.0d0
23541           dCAVdOM12 = 0.0d0
23542           dscj_inv = vbld_inv(j+1)/2.0
23543 !dhead_scbasej(itypi,itypj)
23544 !          print *,i,j,dscj_inv,dsci_inv
23545 ! rij holds 1/(distance of Calpha atoms)
23546           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23547           rij  = dsqrt(rrij)
23548 !----------------------------
23549           CALL sc_angular
23550 ! this should be in elgrad_init but om's are calculated by sc_angular
23551 ! which in turn is used by older potentials
23552 ! om = omega, sqom = om^2
23553           sqom1  = om1 * om1
23554           sqom2  = om2 * om2
23555           sqom12 = om12 * om12
23556
23557 ! now we calculate EGB - Gey-Berne
23558 ! It will be summed up in evdwij and saved in evdw
23559           sigsq     = 1.0D0  / sigsq
23560           sig       = sig0ij * dsqrt(sigsq)
23561 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23562           rij_shift = 1.0/rij - sig + sig0ij
23563           IF (rij_shift.le.0.0D0) THEN
23564            evdw = 1.0D20
23565            RETURN
23566           END IF
23567           sigder = -sig * sigsq
23568           rij_shift = 1.0D0 / rij_shift
23569           fac       = rij_shift**expon
23570           c1        = fac  * fac * aa_scpho(itypi)
23571 !          c1        = 0.0d0
23572           c2        = fac  * bb_scpho(itypi)
23573 !          c2        = 0.0d0
23574           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23575           eps2der   = eps3rt * evdwij
23576           eps3der   = eps2rt * evdwij
23577 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23578           evdwij    = eps2rt * eps3rt * evdwij
23579           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23580           fac    = -expon * (c1 + evdwij) * rij_shift
23581           sigder = fac * sigder
23582 !          fac    = rij * fac
23583 ! Calculate distance derivative
23584           gg(1) =  fac
23585           gg(2) =  fac
23586           gg(3) =  fac
23587           fac = chis1 * sqom1 + chis2 * sqom2 &
23588           - 2.0d0 * chis12 * om1 * om2 * om12
23589 ! we will use pom later in Gcav, so dont mess with it!
23590           pom = 1.0d0 - chis1 * chis2 * sqom12
23591           Lambf = (1.0d0 - (fac / pom))
23592           Lambf = dsqrt(Lambf)
23593           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23594 !       write (*,*) "sparrow = ", sparrow
23595           Chif = 1.0d0/rij * sparrow
23596           ChiLambf = Chif * Lambf
23597           eagle = dsqrt(ChiLambf)
23598           bat = ChiLambf ** 11.0d0
23599           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23600           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23601           botsq = bot * bot
23602           Fcav = top / bot
23603           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23604           dbot = 12.0d0 * b4 * bat * Lambf
23605           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23606 !       dFdR = 0.0d0
23607 !      write (*,*) "dFcav/dR = ", dFdR
23608           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23609           dbot = 12.0d0 * b4 * bat * Chif
23610           eagle = Lambf * pom
23611           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23612           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23613           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23614               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23615
23616           dFdL = ((dtop * bot - top * dbot) / botsq)
23617 !       dFdL = 0.0d0
23618           dCAVdOM1  = dFdL * ( dFdOM1 )
23619           dCAVdOM2  = dFdL * ( dFdOM2 )
23620           dCAVdOM12 = dFdL * ( dFdOM12 )
23621
23622           ertail(1) = xj*rij
23623           ertail(2) = yj*rij
23624           ertail(3) = zj*rij
23625        DO k = 1, 3
23626 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23627 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23628 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
23629
23630         pom = ertail(k)
23631 !        print *,pom,gg(k),dFdR
23632 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23633         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
23634                   - (( dFdR + gg(k) ) * pom)
23635 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23636 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23637 !     &             - ( dFdR * pom )
23638 !        pom = ertail(k)
23639 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23640 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
23641 !                  + (( dFdR + gg(k) ) * pom)
23642 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23643 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23644 !c!     &             + ( dFdR * pom )
23645
23646         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
23647                   - (( dFdR + gg(k) ) * ertail(k))
23648 !c!     &             - ( dFdR * ertail(k))
23649
23650         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
23651                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23652
23653         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
23654                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23655
23656 !c!     &             + ( dFdR * ertail(k))
23657
23658         gg(k) = 0.0d0
23659         ENDDO
23660 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23661 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23662 !      alphapol1 = alphapol_scpho(itypi)
23663        if (wqq_scpho(itypi).ne.0.0) then
23664        Qij=wqq_scpho(itypi)/eps_in
23665        alpha_sco=1.d0/alphi_scpho(itypi)
23666 !       Qij=0.0
23667        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
23668 !c! derivative of Ecl is Gcl...
23669        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
23670                 (Rhead*alpha_sco+1) ) / Rhead_sq
23671        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
23672        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
23673        w1        = wqdip_scpho(1,itypi)
23674        w2        = wqdip_scpho(2,itypi)
23675 !       w1=0.0d0
23676 !       w2=0.0d0
23677 !       pis       = sig0head_scbase(itypi,itypj)
23678 !       eps_head   = epshead_scbase(itypi,itypj)
23679 !c!-------------------------------------------------------------------
23680
23681 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23682 !c!     &        +dhead(1,1,itypi,itypj))**2))
23683 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23684 !c!     &        +dhead(2,1,itypi,itypj))**2))
23685
23686 !c!-------------------------------------------------------------------
23687 !c! ecl
23688        sparrow  = w1  *  om1
23689        hawk     = w2 *  (1.0d0 - sqom2)
23690        Ecl = sparrow / Rhead**2.0d0 &
23691            - hawk    / Rhead**4.0d0
23692 !c!-------------------------------------------------------------------
23693        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
23694            1.0/rij,sparrow
23695
23696 !c! derivative of ecl is Gcl
23697 !c! dF/dr part
23698        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23699                 + 4.0d0 * hawk    / Rhead**5.0d0
23700 !c! dF/dom1
23701        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23702 !c! dF/dom2
23703        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23704        endif
23705
23706 !c--------------------------------------------------------------------
23707 !c Polarization energy
23708 !c Epol
23709        R1 = 0.0d0
23710        DO k = 1, 3
23711 !c! Calculate head-to-tail distances tail is center of side-chain
23712         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
23713        END DO
23714 !c! Pitagoras
23715        R1 = dsqrt(R1)
23716
23717       alphapol1 = alphapol_scpho(itypi)
23718 !      alphapol1=0.0
23719        MomoFac1 = (1.0d0 - chi2 * sqom1)
23720        RR1  = R1 * R1 / MomoFac1
23721        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23722 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
23723        fgb1 = sqrt( RR1 + a12sq * ee1)
23724 !       eps_inout_fac=0.0d0
23725        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23726 ! derivative of Epol is Gpol...
23727        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23728                 / (fgb1 ** 5.0d0)
23729        dFGBdR1 = ( (R1 / MomoFac1) &
23730              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23731              / ( 2.0d0 * fgb1 )
23732        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23733                * (2.0d0 - 0.5d0 * ee1) ) &
23734                / (2.0d0 * fgb1)
23735        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23736 !       dPOLdR1 = 0.0d0
23737 !       dPOLdOM1 = 0.0d0
23738        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
23739                * (2.0d0 - 0.5d0 * ee1) ) &
23740                / (2.0d0 * fgb1)
23741
23742        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
23743        dPOLdOM2 = 0.0
23744        DO k = 1, 3
23745         erhead(k) = Rhead_distance(k)/Rhead
23746         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
23747        END DO
23748
23749        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23750        erdxj = scalar( erhead(1), dC_norm(1,j) )
23751        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23752 !       bat=0.0d0
23753        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
23754        facd1 = d1i * vbld_inv(i+nres)
23755        facd2 = d1j * vbld_inv(j)
23756 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23757
23758        DO k = 1, 3
23759         hawk = (erhead_tail(k,1) + &
23760         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23761 !        facd1=0.0d0
23762 !        facd2=0.0d0
23763 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
23764 !                pom,(erhead_tail(k,1))
23765
23766 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
23767         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23768         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
23769                    - dGCLdR * pom &
23770                    - dPOLdR1 *  (erhead_tail(k,1))
23771 !     &             - dGLJdR * pom
23772
23773         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
23774 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
23775 !                   + dGCLdR * pom  &
23776 !                   + dPOLdR1 * (erhead_tail(k,1))
23777 !     &             + dGLJdR * pom
23778
23779
23780         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
23781                   - dGCLdR * erhead(k) &
23782                   - dPOLdR1 * erhead_tail(k,1)
23783 !     &             - dGLJdR * erhead(k)
23784
23785         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
23786                   + (dGCLdR * erhead(k)  &
23787                   + dPOLdR1 * erhead_tail(k,1))/2.0
23788         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
23789                   + (dGCLdR * erhead(k)  &
23790                   + dPOLdR1 * erhead_tail(k,1))/2.0
23791
23792 !     &             + dGLJdR * erhead(k)
23793 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
23794
23795        END DO
23796 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
23797        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
23798         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
23799        escpho=escpho+evdwij+epol+Fcav+ECL
23800        call sc_grad_scpho
23801          enddo
23802
23803       enddo
23804
23805       return
23806       end subroutine eprot_sc_phosphate
23807       SUBROUTINE sc_grad_scpho
23808       use calc_data
23809
23810        real (kind=8) :: dcosom1(3),dcosom2(3)
23811        eom1  =    &
23812               eps2der * eps2rt_om1   &
23813             - 2.0D0 * alf1 * eps3der &
23814             + sigder * sigsq_om1     &
23815             + dCAVdOM1               &
23816             + dGCLdOM1               &
23817             + dPOLdOM1
23818
23819        eom2  =  &
23820               eps2der * eps2rt_om2   &
23821             + 2.0D0 * alf2 * eps3der &
23822             + sigder * sigsq_om2     &
23823             + dCAVdOM2               &
23824             + dGCLdOM2               &
23825             + dPOLdOM2
23826
23827        eom12 =    &
23828               evdwij  * eps1_om12     &
23829             + eps2der * eps2rt_om12   &
23830             - 2.0D0 * alf12 * eps3der &
23831             + sigder *sigsq_om12      &
23832             + dCAVdOM12               &
23833             + dGCLdOM12
23834 !        om12=0.0
23835 !        eom12=0.0
23836 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23837 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
23838 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23839 !                 *dsci_inv*2.0
23840 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23841 !               gg(1),gg(2),"rozne"
23842        DO k = 1, 3
23843         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23844         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
23845         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23846         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
23847                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
23848                  *dscj_inv*2.0 &
23849                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23850         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
23851                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
23852                  *dscj_inv*2.0 &
23853                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23854         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
23855                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
23856                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23857
23858 !         print *,eom12,eom2,om12,om2
23859 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23860 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23861 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
23862 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23863 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23864         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
23865        END DO
23866        RETURN
23867       END SUBROUTINE sc_grad_scpho
23868       subroutine eprot_pep_phosphate(epeppho)
23869       use calc_data
23870 !      implicit real*8 (a-h,o-z)
23871 !      include 'DIMENSIONS'
23872 !      include 'COMMON.GEO'
23873 !      include 'COMMON.VAR'
23874 !      include 'COMMON.LOCAL'
23875 !      include 'COMMON.CHAIN'
23876 !      include 'COMMON.DERIV'
23877 !      include 'COMMON.NAMES'
23878 !      include 'COMMON.INTERACT'
23879 !      include 'COMMON.IOUNITS'
23880 !      include 'COMMON.CALC'
23881 !      include 'COMMON.CONTROL'
23882 !      include 'COMMON.SBRIDGE'
23883       logical :: lprn
23884 !el local variables
23885       integer :: iint,itypi,itypi1,itypj,subchap
23886       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23887       real(kind=8) :: evdw,sig0ij
23888       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23889                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23890                     sslipi,sslipj,faclip
23891       integer :: ii
23892       real(kind=8) :: fracinbuf
23893        real (kind=8) :: epeppho
23894        real (kind=8),dimension(4):: ener
23895        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23896        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23897         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23898         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23899         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23900         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23901         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23902         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23903        real(kind=8),dimension(3,2)::chead,erhead_tail
23904        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23905        integer troll
23906        real (kind=8) :: dcosom1(3),dcosom2(3)
23907        epeppho=0.0d0
23908 !       do i=1,nres_molec(1)
23909         do i=ibond_start,ibond_end
23910         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23911         itypi  = itype(i,1)
23912         dsci_inv = vbld_inv(i+1)/2.0
23913         dxi    = dc_norm(1,i)
23914         dyi    = dc_norm(2,i)
23915         dzi    = dc_norm(3,i)
23916         xi=(c(1,i)+c(1,i+1))/2.0
23917         yi=(c(2,i)+c(2,i+1))/2.0
23918         zi=(c(3,i)+c(3,i+1))/2.0
23919         xi=mod(xi,boxxsize)
23920          if (xi.lt.0) xi=xi+boxxsize
23921         yi=mod(yi,boxysize)
23922          if (yi.lt.0) yi=yi+boxysize
23923         zi=mod(zi,boxzsize)
23924          if (zi.lt.0) zi=zi+boxzsize
23925          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23926            itypj= itype(j,2)
23927            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23928             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23929            xj=(c(1,j)+c(1,j+1))/2.0
23930            yj=(c(2,j)+c(2,j+1))/2.0
23931            zj=(c(3,j)+c(3,j+1))/2.0
23932            xj=dmod(xj,boxxsize)
23933            if (xj.lt.0) xj=xj+boxxsize
23934            yj=dmod(yj,boxysize)
23935            if (yj.lt.0) yj=yj+boxysize
23936            zj=dmod(zj,boxzsize)
23937            if (zj.lt.0) zj=zj+boxzsize
23938           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23939           xj_safe=xj
23940           yj_safe=yj
23941           zj_safe=zj
23942           subchap=0
23943           do xshift=-1,1
23944           do yshift=-1,1
23945           do zshift=-1,1
23946           xj=xj_safe+xshift*boxxsize
23947           yj=yj_safe+yshift*boxysize
23948           zj=zj_safe+zshift*boxzsize
23949           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23950           if(dist_temp.lt.dist_init) then
23951             dist_init=dist_temp
23952             xj_temp=xj
23953             yj_temp=yj
23954             zj_temp=zj
23955             subchap=1
23956           endif
23957           enddo
23958           enddo
23959           enddo
23960           if (subchap.eq.1) then
23961           xj=xj_temp-xi
23962           yj=yj_temp-yi
23963           zj=zj_temp-zi
23964           else
23965           xj=xj_safe-xi
23966           yj=yj_safe-yi
23967           zj=zj_safe-zi
23968           endif
23969           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23970           rij  = dsqrt(rrij)
23971           dxj = dc_norm( 1,j )
23972           dyj = dc_norm( 2,j )
23973           dzj = dc_norm( 3,j )
23974           dscj_inv = vbld_inv(j+1)/2.0
23975 ! Gay-berne var's
23976           sig0ij = sigma_peppho
23977           chi1=0.0d0
23978           chi2=0.0d0
23979           chi12  = chi1 * chi2
23980           chip1=0.0d0
23981           chip2=0.0d0
23982           chip12 = chip1 * chip2
23983           chis1 = 0.0d0
23984           chis2 = 0.0d0
23985           chis12 = chis1 * chis2
23986           sig1 = sigmap1_peppho
23987           sig2 = sigmap2_peppho
23988 !       write (*,*) "sig1 = ", sig1
23989 !       write (*,*) "sig1 = ", sig1
23990 !       write (*,*) "sig2 = ", sig2
23991 ! alpha factors from Fcav/Gcav
23992           alf1   = 0.0d0
23993           alf2   = 0.0d0
23994           alf12  = 0.0d0
23995           b1 = alphasur_peppho(1)
23996 !          b1=0.0d0
23997           b2 = alphasur_peppho(2)
23998           b3 = alphasur_peppho(3)
23999           b4 = alphasur_peppho(4)
24000           CALL sc_angular
24001        sqom1=om1*om1
24002        evdwij = 0.0d0
24003        ECL = 0.0d0
24004        Elj = 0.0d0
24005        Equad = 0.0d0
24006        Epol = 0.0d0
24007        Fcav=0.0d0
24008        eheadtail = 0.0d0
24009        dGCLdR=0.0d0
24010        dGCLdOM1 = 0.0d0
24011        dGCLdOM2 = 0.0d0
24012        dGCLdOM12 = 0.0d0
24013        dPOLdOM1 = 0.0d0
24014        dPOLdOM2 = 0.0d0
24015           Fcav = 0.0d0
24016           dFdR = 0.0d0
24017           dCAVdOM1  = 0.0d0
24018           dCAVdOM2  = 0.0d0
24019           dCAVdOM12 = 0.0d0
24020           rij_shift = rij
24021           fac       = rij_shift**expon
24022           c1        = fac  * fac * aa_peppho
24023 !          c1        = 0.0d0
24024           c2        = fac  * bb_peppho
24025 !          c2        = 0.0d0
24026           evdwij    =  c1 + c2
24027 ! Now cavity....................
24028        eagle = dsqrt(1.0/rij_shift)
24029        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24030           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24031           botsq = bot * bot
24032           Fcav = top / bot
24033           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24034           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24035           dFdR = ((dtop * bot - top * dbot) / botsq)
24036        w1        = wqdip_peppho(1)
24037        w2        = wqdip_peppho(2)
24038 !       w1=0.0d0
24039 !       w2=0.0d0
24040 !       pis       = sig0head_scbase(itypi,itypj)
24041 !       eps_head   = epshead_scbase(itypi,itypj)
24042 !c!-------------------------------------------------------------------
24043
24044 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24045 !c!     &        +dhead(1,1,itypi,itypj))**2))
24046 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24047 !c!     &        +dhead(2,1,itypi,itypj))**2))
24048
24049 !c!-------------------------------------------------------------------
24050 !c! ecl
24051        sparrow  = w1  *  om1
24052        hawk     = w2 *  (1.0d0 - sqom1)
24053        Ecl = sparrow * rij_shift**2.0d0 &
24054            - hawk    * rij_shift**4.0d0
24055 !c!-------------------------------------------------------------------
24056 !c! derivative of ecl is Gcl
24057 !c! dF/dr part
24058 !       rij_shift=5.0
24059        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24060                 + 4.0d0 * hawk    * rij_shift**5.0d0
24061 !c! dF/dom1
24062        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24063 !c! dF/dom2
24064        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24065        eom1  =    dGCLdOM1+dGCLdOM2
24066        eom2  =    0.0
24067
24068           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24069 !          fac=0.0
24070           gg(1) =  fac*xj*rij
24071           gg(2) =  fac*yj*rij
24072           gg(3) =  fac*zj*rij
24073          do k=1,3
24074          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24075          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24076          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24077          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24078          gg(k)=0.0
24079          enddo
24080
24081       DO k = 1, 3
24082         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24083         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24084         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24085         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24086 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24087         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24088 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24089         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24090                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24091         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24092                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24093         enddo
24094        epeppho=epeppho+evdwij+Fcav+ECL
24095 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24096        enddo
24097        enddo
24098       end subroutine eprot_pep_phosphate
24099       end module energy