source/unres/energy.f90

   1       module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 ! Maximum number of local shielding effectors
  33       integer,parameter :: maxcontsshi=50
  34 !-----------------------------------------------------------------------------
  35 ! commom.calc common/calc/
  36 !-----------------------------------------------------------------------------
  37 ! commom.contacts
  38 !      common /contacts/
  39 ! Change 12/1/95 - common block CONTACTS1 included.
  40 !      common /contacts1/
  41
  42       integer,dimension(:),allocatable :: num_cont      !(maxres)
  43       integer,dimension(:,:),allocatable :: jcont      !(maxconts,maxres)
  44       real(kind=8),dimension(:,:),allocatable :: facont,ees0plist      !(maxconts,maxres)
  45       real(kind=8),dimension(:,:,:),allocatable :: gacont      !(3,maxconts,maxres)
  46       integer,dimension(:),allocatable :: ishield_list
  47       integer,dimension(:,:),allocatable ::  shield_list
  48       real(kind=8),dimension(:),allocatable :: enetube,enecavtube
  49 !
  50 ! 12/26/95 - H-bonding contacts
  51 !      common /contacts_hb/
  52       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  53        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont      !(3,maxconts,maxres)
  54       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  55         ees0m,d_cont      !(maxconts,maxres)
  56       integer,dimension(:),allocatable :: num_cont_hb      !(maxres)
  57       integer,dimension(:,:),allocatable :: jcont_hb      !(maxconts,maxres)
  58 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  59 !         interactions
  60 ! 7/25/08 commented out; not needed when cumulants used
  61 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  62 !  common /dipint/
  63       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  64          dipderg      !(4,maxconts,maxres)
  65       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  66 ! 10/30/99 Added other pre-computed vectors and matrices needed
  67 !          to calculate three - six-order el-loc correlation terms
  68 ! common /rotat/
  69       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der      !(2,2,maxres)
  70       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  71        obrot2_der      !(2,maxres)
  72 !
  73 ! This common block contains vectors and matrices dependent on a single
  74 ! amino-acid residue.
  75 !      common /precomp1/
  76       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  77        Ctobr,Ctobrder,Dtobr2,Dtobr2der      !(2,maxres)
  78       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  79        CUgder,DUg,Dugder,DtUg2,DtUg2der      !(2,2,maxres)
  80 ! This common block contains vectors and matrices dependent on two
  81 ! consecutive amino-acid residues.
  82 !      common /precomp2/
  83       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  84        CUgb2,CUgb2der      !(2,maxres)
  85       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  86        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg      !(2,2,maxres)
  87       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  88        DtUg2EUgder      !(2,2,2,maxres)
  89 !      common /rotat_old/
  90       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  91        costab2,sintab2      !(maxres)
  92 ! This common block contains dipole-interaction matrices and their
  93 ! Cartesian derivatives.
  94 !      common /dipmat/
  95       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj      !(2,2,maxconts,maxres)
  96       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der      !(2,2,3,5,maxconts,maxres)
  97 !      common /diploc/
  98       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  99        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 100       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 101        ADtEA1derg,AEAb2derg
 102       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 103        AECAderx,ADtEAderx,ADtEA1derx
 104       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 105       real(kind=8),dimension(3,2) :: g_contij
 106       real(kind=8) :: ekont
 107 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 108 !   RE: Parallelization of 4th and higher order loc-el correlations
 109 !      common /contdistrib/
 110       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 111 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 112 !-----------------------------------------------------------------------------
 113 ! commom.deriv;
 114 !      common /derivat/
 115 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 116 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 117 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 118       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 119         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 120         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 121         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 122         gliptranx, &
 123         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 124         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 125         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 126         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 127         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 128 !-----------------------------NUCLEIC GRADIENT
 129       real(kind=8),dimension(:,:),allocatable  ::gradb_nucl,gradbx_nucl, &
 130         gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc,gsbloc,&
 131         gsblocx,gradcorr_nucl,gradxorr_nucl,gradcorr3_nucl,gradxorr3_nucl,&
 132         gvdwpp_nucl
 133 !-----------------------------NUCLEIC-PROTEIN GRADIENT
 134       real(kind=8),dimension(:,:),allocatable  :: gvdwx_scbase,gvdwc_scbase,&
 135          gvdwx_pepbase,gvdwc_pepbase,gvdwx_scpho,gvdwc_scpho,&
 136          gvdwc_peppho
 137 !------------------------------IONS GRADIENT
 138         real(kind=8),dimension(:,:),allocatable  ::  gradcatcat, &
 139           gradpepcat,gradpepcatx
 140 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 141
 142
 143       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 144         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 145       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 146         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 147         g_corr6_loc      !(maxvar)
 148       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 149       real(kind=8),dimension(:),allocatable :: gsccor_loc      !(maxres)
 150 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 151       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 152 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 153       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 154          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 155 !      integer :: nfl,icg
 156 !      common /deriv_loc/
 157       real(kind=8), dimension(:),allocatable :: fac_shield
 158       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 159 !      common /deriv_scloc/
 160       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 161        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 162        dZZ_XYZtab      !(3,maxres)
 163 !-----------------------------------------------------------------------------
 164 ! common.maxgrad
 165 !      common /maxgrad/
 166       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 167        gradb_max,ghpbc_max,&
 168        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 169        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 170        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 171        gsccorx_max,gsclocx_max
 172 !-----------------------------------------------------------------------------
 173 ! common.MD
 174 !      common /back_constr/
 175       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 176       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 177 !      common /qmeas/
 178       real(kind=8) :: Ucdfrag,Ucdpair
 179       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 180        dqwol,dxqwol      !(3,0:MAXRES)
 181 !-----------------------------------------------------------------------------
 182 ! common.sbridge
 183 !      common /dyn_ssbond/
 184       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 185 !-----------------------------------------------------------------------------
 186 ! common.sccor
 187 ! Parameters of the SCCOR term
 188 !      common/sccor/
 189       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 190        dcosomicron,domicron      !(3,3,3,maxres2)
 191 !-----------------------------------------------------------------------------
 192 ! common.vectors
 193 !      common /vectors/
 194       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 195       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 196 !-----------------------------------------------------------------------------
 197 ! common /przechowalnia/
 198       real(kind=8),dimension(:,:,:),allocatable :: zapas
 199       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 200       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 201 !-----------------------------------------------------------------------------
 202 !-----------------------------------------------------------------------------
 203 !
 204 !
 205 !-----------------------------------------------------------------------------
 206       contains
 207 !-----------------------------------------------------------------------------
 208 ! energy_p_new_barrier.F
 209 !-----------------------------------------------------------------------------
 210       subroutine etotal(energia)
 211 !      implicit real*8 (a-h,o-z)
 212 !      include 'DIMENSIONS'
 213       use MD_data
 214 #ifndef ISNAN
 215       external proc_proc
 216 #ifdef WINPGI
 217 !MS$ATTRIBUTES C ::  proc_proc
 218 #endif
 219 #endif
 220 #ifdef MPI
 221       include "mpif.h"
 222 #endif
 223 !      include 'COMMON.SETUP'
 224 !      include 'COMMON.IOUNITS'
 225       real(kind=8),dimension(0:n_ene) :: energia
 226 !      include 'COMMON.LOCAL'
 227 !      include 'COMMON.FFIELD'
 228 !      include 'COMMON.DERIV'
 229 !      include 'COMMON.INTERACT'
 230 !      include 'COMMON.SBRIDGE'
 231 !      include 'COMMON.CHAIN'
 232 !      include 'COMMON.VAR'
 233 !      include 'COMMON.MD'
 234 !      include 'COMMON.CONTROL'
 235 !      include 'COMMON.TIME1'
 236       real(kind=8) :: time00
 237 !el local variables
 238       integer :: n_corr,n_corr1,ierror
 239       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 240       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 241       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 242                       Eafmforce,ethetacnstr
 243       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 244 ! now energies for nulceic alone parameters
 245       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 246                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 247                       ecorr3_nucl
 248 ! energies for ions
 249       real(kind=8) :: ecation_prot,ecationcation
 250 ! energies for protein nucleic acid interaction
 251       real(kind=8) :: escbase,epepbase,escpho,epeppho
 252
 253 #ifdef MPI
 254       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 255 ! shielding effect varibles for MPI
 256 !      real(kind=8)   fac_shieldbuf(maxres),
 257 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 258 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 259 !     & grad_shieldbuf(3,-1:maxres)
 260 !       integer ishield_listbuf(maxres),
 261 !     &shield_listbuf(maxcontsshi,maxres)
 262
 263 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 264 !     & " nfgtasks",nfgtasks
 265       if (nfgtasks.gt.1) then
 266         time00=MPI_Wtime()
 267 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 268         if (fg_rank.eq.0) then
 269           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 270 !          print *,"Processor",myrank," BROADCAST iorder"
 271 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 272 ! FG slaves as WEIGHTS array.
 273           weights_(1)=wsc
 274           weights_(2)=wscp
 275           weights_(3)=welec
 276           weights_(4)=wcorr
 277           weights_(5)=wcorr5
 278           weights_(6)=wcorr6
 279           weights_(7)=wel_loc
 280           weights_(8)=wturn3
 281           weights_(9)=wturn4
 282           weights_(10)=wturn6
 283           weights_(11)=wang
 284           weights_(12)=wscloc
 285           weights_(13)=wtor
 286           weights_(14)=wtor_d
 287           weights_(15)=wstrain
 288           weights_(16)=wvdwpp
 289           weights_(17)=wbond
 290           weights_(18)=scal14
 291           weights_(21)=wsccor
 292           weights_(26)=wvdwpp_nucl
 293           weights_(27)=welpp
 294           weights_(28)=wvdwpsb
 295           weights_(29)=welpsb
 296           weights_(30)=wvdwsb
 297           weights_(31)=welsb
 298           weights_(32)=wbond_nucl
 299           weights_(33)=wang_nucl
 300           weights_(34)=wsbloc
 301           weights_(35)=wtor_nucl
 302           weights_(36)=wtor_d_nucl
 303           weights_(37)=wcorr_nucl
 304           weights_(38)=wcorr3_nucl
 305           weights_(41)=wcatcat
 306           weights_(42)=wcatprot
 307           weights_(46)=wscbase
 308           weights_(47)=wscpho
 309           weights_(48)=wpeppho
 310 !          wcatcat= weights(41)
 311 !          wcatprot=weights(42)
 312
 313 ! FG Master broadcasts the WEIGHTS_ array
 314           call MPI_Bcast(weights_(1),n_ene,&
 315              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 316         else
 317 ! FG slaves receive the WEIGHTS array
 318           call MPI_Bcast(weights(1),n_ene,&
 319               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 320           wsc=weights(1)
 321           wscp=weights(2)
 322           welec=weights(3)
 323           wcorr=weights(4)
 324           wcorr5=weights(5)
 325           wcorr6=weights(6)
 326           wel_loc=weights(7)
 327           wturn3=weights(8)
 328           wturn4=weights(9)
 329           wturn6=weights(10)
 330           wang=weights(11)
 331           wscloc=weights(12)
 332           wtor=weights(13)
 333           wtor_d=weights(14)
 334           wstrain=weights(15)
 335           wvdwpp=weights(16)
 336           wbond=weights(17)
 337           scal14=weights(18)
 338           wsccor=weights(21)
 339           wvdwpp_nucl =weights(26)
 340           welpp  =weights(27)
 341           wvdwpsb=weights(28)
 342           welpsb =weights(29)
 343           wvdwsb =weights(30)
 344           welsb  =weights(31)
 345           wbond_nucl  =weights(32)
 346           wang_nucl   =weights(33)
 347           wsbloc =weights(34)
 348           wtor_nucl   =weights(35)
 349           wtor_d_nucl =weights(36)
 350           wcorr_nucl  =weights(37)
 351           wcorr3_nucl =weights(38)
 352           wcatcat= weights(41)
 353           wcatprot=weights(42)
 354           wscbase=weights(46)
 355           wscpho=weights(47)
 356           wpeppho=weights(48)
 357         endif
 358         time_Bcast=time_Bcast+MPI_Wtime()-time00
 359         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 360 !        call chainbuild_cart
 361       endif
 362 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 363 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 364 #else
 365 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 366 !        call int_from_cart1(.false.)
 367 !      endif
 368 #endif
 369 #ifdef TIMING
 370       time00=MPI_Wtime()
 371 #endif
 372 !
 373 ! Compute the side-chain and electrostatic interaction energy
 374 !        print *, "Before EVDW"
 375 !      goto (101,102,103,104,105,106) ipot
 376       select case(ipot)
 377 ! Lennard-Jones potential.
 378 !  101 call elj(evdw)
 379        case (1)
 380          call elj(evdw)
 381 !d    print '(a)','Exit ELJcall el'
 382 !      goto 107
 383 ! Lennard-Jones-Kihara potential (shifted).
 384 !  102 call eljk(evdw)
 385        case (2)
 386          call eljk(evdw)
 387 !      goto 107
 388 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 389 !  103 call ebp(evdw)
 390        case (3)
 391          call ebp(evdw)
 392 !      goto 107
 393 ! Gay-Berne potential (shifted LJ, angular dependence).
 394 !  104 call egb(evdw)
 395        case (4)
 396          call egb(evdw)
 397 !      goto 107
 398 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 399 !  105 call egbv(evdw)
 400        case (5)
 401          call egbv(evdw)
 402 !      goto 107
 403 ! Soft-sphere potential
 404 !  106 call e_softsphere(evdw)
 405        case (6)
 406          call e_softsphere(evdw)
 407 !
 408 ! Calculate electrostatic (H-bonding) energy of the main chain.
 409 !
 410 !  107 continue
 411        case default
 412          write(iout,*)"Wrong ipot"
 413 !         return
 414 !   50 continue
 415       end select
 416 !      continue
 417 !        print *,"after EGB"
 418 ! shielding effect
 419        if (shield_mode.eq.2) then
 420                  call set_shield_fac2
 421        endif
 422 !       print *,"AFTER EGB",ipot,evdw
 423 !mc
 424 !mc Sep-06: egb takes care of dynamic ss bonds too
 425 !mc
 426 !      if (dyn_ss) call dyn_set_nss
 427 !      print *,"Processor",myrank," computed USCSC"
 428 #ifdef TIMING
 429       time01=MPI_Wtime()
 430 #endif
 431       call vec_and_deriv
 432 #ifdef TIMING
 433       time_vec=time_vec+MPI_Wtime()-time01
 434 #endif
 435 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 436       if (ipot.lt.6) then
 437 #ifdef SPLITELE
 438 !         print *,"after ipot if", ipot
 439          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 440              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 441              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 442              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 443 #else
 444          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 445              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 446              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 447              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 448 #endif
 449 !            print *,"just befor eelec call"
 450             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 451 !         write (iout,*) "ELEC calc"
 452          else
 453             ees=0.0d0
 454             evdw1=0.0d0
 455             eel_loc=0.0d0
 456             eello_turn3=0.0d0
 457             eello_turn4=0.0d0
 458          endif
 459       else
 460 !        write (iout,*) "Soft-spheer ELEC potential"
 461         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 462          eello_turn4)
 463       endif
 464 !      print *,"Processor",myrank," computed UELEC"
 465 !
 466 ! Calculate excluded-volume interaction energy between peptide groups
 467 ! and side chains.
 468 !
 469 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 470
 471       if (ipot.lt.6) then
 472        if(wscp.gt.0d0) then
 473         call escp(evdw2,evdw2_14)
 474        else
 475         evdw2=0
 476         evdw2_14=0
 477        endif
 478       else
 479 !        write (iout,*) "Soft-sphere SCP potential"
 480         call escp_soft_sphere(evdw2,evdw2_14)
 481       endif
 482 !       write(iout,*) "in etotal before ebond",ipot
 483
 484 !
 485 ! Calculate the bond-stretching energy
 486 !
 487       call ebond(estr)
 488 !       print *,"EBOND",estr
 489 !       write(iout,*) "in etotal afer ebond",ipot
 490
 491 !
 492 ! Calculate the disulfide-bridge and other energy and the contributions
 493 ! from other distance constraints.
 494 !      print *,'Calling EHPB'
 495       call edis(ehpb)
 496 !elwrite(iout,*) "in etotal afer edis",ipot
 497 !      print *,'EHPB exitted succesfully.'
 498 !
 499 ! Calculate the virtual-bond-angle energy.
 500 !
 501       if (wang.gt.0d0) then
 502         call ebend(ebe,ethetacnstr)
 503       else
 504         ebe=0
 505         ethetacnstr=0
 506       endif
 507 !      print *,"Processor",myrank," computed UB"
 508 !
 509 ! Calculate the SC local energy.
 510 !
 511       call esc(escloc)
 512 !elwrite(iout,*) "in etotal afer esc",ipot
 513 !      print *,"Processor",myrank," computed USC"
 514 !
 515 ! Calculate the virtual-bond torsional energy.
 516 !
 517 !d    print *,'nterm=',nterm
 518       if (wtor.gt.0) then
 519        call etor(etors,edihcnstr)
 520       else
 521        etors=0
 522        edihcnstr=0
 523       endif
 524 !      print *,"Processor",myrank," computed Utor"
 525 !
 526 ! 6/23/01 Calculate double-torsional energy
 527 !
 528 !elwrite(iout,*) "in etotal",ipot
 529       if (wtor_d.gt.0) then
 530        call etor_d(etors_d)
 531       else
 532        etors_d=0
 533       endif
 534 !      print *,"Processor",myrank," computed Utord"
 535 !
 536 ! 21/5/07 Calculate local sicdechain correlation energy
 537 !
 538       if (wsccor.gt.0.0d0) then
 539         call eback_sc_corr(esccor)
 540       else
 541         esccor=0.0d0
 542       endif
 543 !      print *,"Processor",myrank," computed Usccorr"
 544 !
 545 ! 12/1/95 Multi-body terms
 546 !
 547       n_corr=0
 548       n_corr1=0
 549       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 550           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 551          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 552 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 553 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 554       else
 555          ecorr=0.0d0
 556          ecorr5=0.0d0
 557          ecorr6=0.0d0
 558          eturn6=0.0d0
 559       endif
 560 !elwrite(iout,*) "in etotal",ipot
 561       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 562          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 563 !d         write (iout,*) "multibody_hb ecorr",ecorr
 564       endif
 565 !elwrite(iout,*) "afeter  multibody hb"
 566
 567 !      print *,"Processor",myrank," computed Ucorr"
 568 !
 569 ! If performing constraint dynamics, call the constraint energy
 570 !  after the equilibration time
 571       if(usampl.and.totT.gt.eq_time) then
 572 !elwrite(iout,*) "afeter  multibody hb"
 573          call EconstrQ
 574 !elwrite(iout,*) "afeter  multibody hb"
 575          call Econstr_back
 576 !elwrite(iout,*) "afeter  multibody hb"
 577       else
 578          Uconst=0.0d0
 579          Uconst_back=0.0d0
 580       endif
 581       call flush(iout)
 582 !         write(iout,*) "after Econstr"
 583
 584       if (wliptran.gt.0) then
 585 !        print *,"PRZED WYWOLANIEM"
 586         call Eliptransfer(eliptran)
 587       else
 588        eliptran=0.0d0
 589       endif
 590       if (fg_rank.eq.0) then
 591       if (AFMlog.gt.0) then
 592         call AFMforce(Eafmforce)
 593       else if (selfguide.gt.0) then
 594         call AFMvel(Eafmforce)
 595       endif
 596       endif
 597       if (tubemode.eq.1) then
 598        call calctube(etube)
 599       else if (tubemode.eq.2) then
 600        call calctube2(etube)
 601       elseif (tubemode.eq.3) then
 602        call calcnano(etube)
 603       else
 604        etube=0.0d0
 605       endif
 606 !--------------------------------------------------------
 607 !      write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 608 !      print *,"before",ees,evdw1,ecorr
 609       if (nres_molec(2).gt.0) then
 610       call ebond_nucl(estr_nucl)
 611       call ebend_nucl(ebe_nucl)
 612       call etor_nucl(etors_nucl)
 613       call esb_gb(evdwsb,eelsb)
 614       call epp_nucl_sub(evdwpp,eespp)
 615       call epsb(evdwpsb,eelpsb)
 616       call esb(esbloc)
 617       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 618       else
 619        etors_nucl=0.0d0
 620        estr_nucl=0.0d0
 621        ebe_nucl=0.0d0
 622        evdwsb=0.0d0
 623        eelsb=0.0d0
 624        esbloc=0.0d0
 625       endif
 626       if (nfgtasks.gt.1) then
 627       if (fg_rank.eq.0) then
 628       call ecatcat(ecationcation)
 629       endif
 630       else
 631       call ecatcat(ecationcation)
 632       endif
 633       call ecat_prot(ecation_prot)
 634       if (nres_molec(2).gt.0) then
 635       call eprot_sc_base(escbase)
 636       call epep_sc_base(epepbase)
 637       call eprot_sc_phosphate(escpho)
 638       call eprot_pep_phosphate(epeppho)
 639       endif
 640 !      call ecatcat(ecationcation)
 641 !      print *,"after ebend", ebe_nucl
 642 #ifdef TIMING
 643       time_enecalc=time_enecalc+MPI_Wtime()-time00
 644 #endif
 645 !      print *,"Processor",myrank," computed Uconstr"
 646 #ifdef TIMING
 647       time00=MPI_Wtime()
 648 #endif
 649 !
 650 ! Sum the energies
 651 !
 652       energia(1)=evdw
 653 #ifdef SCP14
 654       energia(2)=evdw2-evdw2_14
 655       energia(18)=evdw2_14
 656 #else
 657       energia(2)=evdw2
 658       energia(18)=0.0d0
 659 #endif
 660 #ifdef SPLITELE
 661       energia(3)=ees
 662       energia(16)=evdw1
 663 #else
 664       energia(3)=ees+evdw1
 665       energia(16)=0.0d0
 666 #endif
 667       energia(4)=ecorr
 668       energia(5)=ecorr5
 669       energia(6)=ecorr6
 670       energia(7)=eel_loc
 671       energia(8)=eello_turn3
 672       energia(9)=eello_turn4
 673       energia(10)=eturn6
 674       energia(11)=ebe
 675       energia(12)=escloc
 676       energia(13)=etors
 677       energia(14)=etors_d
 678       energia(15)=ehpb
 679       energia(19)=edihcnstr
 680       energia(17)=estr
 681       energia(20)=Uconst+Uconst_back
 682       energia(21)=esccor
 683       energia(22)=eliptran
 684       energia(23)=Eafmforce
 685       energia(24)=ethetacnstr
 686       energia(25)=etube
 687 !---------------------------------------------------------------
 688       energia(26)=evdwpp
 689       energia(27)=eespp
 690       energia(28)=evdwpsb
 691       energia(29)=eelpsb
 692       energia(30)=evdwsb
 693       energia(31)=eelsb
 694       energia(32)=estr_nucl
 695       energia(33)=ebe_nucl
 696       energia(34)=esbloc
 697       energia(35)=etors_nucl
 698       energia(36)=etors_d_nucl
 699       energia(37)=ecorr_nucl
 700       energia(38)=ecorr3_nucl
 701 !----------------------------------------------------------------------
 702 !    Here are the energies showed per procesor if the are more processors
 703 !    per molecule then we sum it up in sum_energy subroutine
 704 !      print *," Processor",myrank," calls SUM_ENERGY"
 705       energia(41)=ecation_prot
 706       energia(42)=ecationcation
 707       energia(46)=escbase
 708       energia(47)=epepbase
 709       energia(48)=escpho
 710       energia(49)=epeppho
 711       call sum_energy(energia,.true.)
 712       if (dyn_ss) call dyn_set_nss
 713 !      print *," Processor",myrank," left SUM_ENERGY"
 714 #ifdef TIMING
 715       time_sumene=time_sumene+MPI_Wtime()-time00
 716 #endif
 717 !el        call enerprint(energia)
 718 !elwrite(iout,*)"finish etotal"
 719       return
 720       end subroutine etotal
 721 !-----------------------------------------------------------------------------
 722       subroutine sum_energy(energia,reduce)
 723 !      implicit real*8 (a-h,o-z)
 724 !      include 'DIMENSIONS'
 725 #ifndef ISNAN
 726       external proc_proc
 727 #ifdef WINPGI
 728 !MS$ATTRIBUTES C ::  proc_proc
 729 #endif
 730 #endif
 731 #ifdef MPI
 732       include "mpif.h"
 733 #endif
 734 !      include 'COMMON.SETUP'
 735 !      include 'COMMON.IOUNITS'
 736       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 737 !      include 'COMMON.FFIELD'
 738 !      include 'COMMON.DERIV'
 739 !      include 'COMMON.INTERACT'
 740 !      include 'COMMON.SBRIDGE'
 741 !      include 'COMMON.CHAIN'
 742 !      include 'COMMON.VAR'
 743 !      include 'COMMON.CONTROL'
 744 !      include 'COMMON.TIME1'
 745       logical :: reduce
 746       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 747       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 748       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 749         eliptran,etube, Eafmforce,ethetacnstr
 750       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 751                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 752                       ecorr3_nucl
 753       real(kind=8) :: ecation_prot,ecationcation
 754       real(kind=8) :: escbase,epepbase,escpho,epeppho
 755       integer :: i
 756 #ifdef MPI
 757       integer :: ierr
 758       real(kind=8) :: time00
 759       if (nfgtasks.gt.1 .and. reduce) then
 760
 761 #ifdef DEBUG
 762         write (iout,*) "energies before REDUCE"
 763         call enerprint(energia)
 764         call flush(iout)
 765 #endif
 766         do i=0,n_ene
 767           enebuff(i)=energia(i)
 768         enddo
 769         time00=MPI_Wtime()
 770         call MPI_Barrier(FG_COMM,IERR)
 771         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 772         time00=MPI_Wtime()
 773         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 774           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 775 #ifdef DEBUG
 776         write (iout,*) "energies after REDUCE"
 777         call enerprint(energia)
 778         call flush(iout)
 779 #endif
 780         time_Reduce=time_Reduce+MPI_Wtime()-time00
 781       endif
 782       if (fg_rank.eq.0) then
 783 #endif
 784       evdw=energia(1)
 785 #ifdef SCP14
 786       evdw2=energia(2)+energia(18)
 787       evdw2_14=energia(18)
 788 #else
 789       evdw2=energia(2)
 790 #endif
 791 #ifdef SPLITELE
 792       ees=energia(3)
 793       evdw1=energia(16)
 794 #else
 795       ees=energia(3)
 796       evdw1=0.0d0
 797 #endif
 798       ecorr=energia(4)
 799       ecorr5=energia(5)
 800       ecorr6=energia(6)
 801       eel_loc=energia(7)
 802       eello_turn3=energia(8)
 803       eello_turn4=energia(9)
 804       eturn6=energia(10)
 805       ebe=energia(11)
 806       escloc=energia(12)
 807       etors=energia(13)
 808       etors_d=energia(14)
 809       ehpb=energia(15)
 810       edihcnstr=energia(19)
 811       estr=energia(17)
 812       Uconst=energia(20)
 813       esccor=energia(21)
 814       eliptran=energia(22)
 815       Eafmforce=energia(23)
 816       ethetacnstr=energia(24)
 817       etube=energia(25)
 818       evdwpp=energia(26)
 819       eespp=energia(27)
 820       evdwpsb=energia(28)
 821       eelpsb=energia(29)
 822       evdwsb=energia(30)
 823       eelsb=energia(31)
 824       estr_nucl=energia(32)
 825       ebe_nucl=energia(33)
 826       esbloc=energia(34)
 827       etors_nucl=energia(35)
 828       etors_d_nucl=energia(36)
 829       ecorr_nucl=energia(37)
 830       ecorr3_nucl=energia(38)
 831       ecation_prot=energia(41)
 832       ecationcation=energia(42)
 833       escbase=energia(46)
 834       epepbase=energia(47)
 835       escpho=energia(48)
 836       epeppho=energia(49)
 837 !      energia(41)=ecation_prot
 838 !      energia(42)=ecationcation
 839
 840
 841 #ifdef SPLITELE
 842       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 843        +wang*ebe+wtor*etors+wscloc*escloc &
 844        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 845        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 846        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 847        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 848        +Eafmforce+ethetacnstr  &
 849        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 850        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 851        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 852        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 853        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 854        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 855 #else
 856       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 857        +wang*ebe+wtor*etors+wscloc*escloc &
 858        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 859        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 860        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 861        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 862        +Eafmforce+ethetacnstr &
 863        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 864        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 865        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 866        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 867        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 868        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 869 #endif
 870       energia(0)=etot
 871 ! detecting NaNQ
 872 #ifdef ISNAN
 873 #ifdef AIX
 874       if (isnan(etot).ne.0) energia(0)=1.0d+99
 875 #else
 876       if (isnan(etot)) energia(0)=1.0d+99
 877 #endif
 878 #else
 879       i=0
 880 #ifdef WINPGI
 881       idumm=proc_proc(etot,i)
 882 #else
 883       call proc_proc(etot,i)
 884 #endif
 885       if(i.eq.1)energia(0)=1.0d+99
 886 #endif
 887 #ifdef MPI
 888       endif
 889 #endif
 890 !      call enerprint(energia)
 891       call flush(iout)
 892       return
 893       end subroutine sum_energy
 894 !-----------------------------------------------------------------------------
 895       subroutine rescale_weights(t_bath)
 896 !      implicit real*8 (a-h,o-z)
 897 #ifdef MPI
 898       include 'mpif.h'
 899 #endif
 900 !      include 'DIMENSIONS'
 901 !      include 'COMMON.IOUNITS'
 902 !      include 'COMMON.FFIELD'
 903 !      include 'COMMON.SBRIDGE'
 904       real(kind=8) :: kfac=2.4d0
 905       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 906 !el local variables
 907       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 908       real(kind=8) :: T0=3.0d2
 909       integer :: ierror
 910 !      facT=temp0/t_bath
 911 !      facT=2*temp0/(t_bath+temp0)
 912       if (rescale_mode.eq.0) then
 913         facT(1)=1.0d0
 914         facT(2)=1.0d0
 915         facT(3)=1.0d0
 916         facT(4)=1.0d0
 917         facT(5)=1.0d0
 918         facT(6)=1.0d0
 919       else if (rescale_mode.eq.1) then
 920         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 921         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 922         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 923         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 924         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 925 #ifdef WHAM_RUN
 926 !#if defined(WHAM_RUN) || defined(CLUSTER)
 927 #if defined(FUNCTH)
 928 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 929         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 930 #elif defined(FUNCT)
 931         facT(6)=t_bath/T0
 932 #else
 933         facT(6)=1.0d0
 934 #endif
 935 #endif
 936       else if (rescale_mode.eq.2) then
 937         x=t_bath/temp0
 938         x2=x*x
 939         x3=x2*x
 940         x4=x3*x
 941         x5=x4*x
 942         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 943         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 944         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 945         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 946         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 947 #ifdef WHAM_RUN
 948 !#if defined(WHAM_RUN) || defined(CLUSTER)
 949 #if defined(FUNCTH)
 950         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 951 #elif defined(FUNCT)
 952         facT(6)=t_bath/T0
 953 #else
 954         facT(6)=1.0d0
 955 #endif
 956 #endif
 957       else
 958         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 959         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 960 #ifdef MPI
 961        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 962 #endif
 963        stop 555
 964       endif
 965       welec=weights(3)*fact(1)
 966       wcorr=weights(4)*fact(3)
 967       wcorr5=weights(5)*fact(4)
 968       wcorr6=weights(6)*fact(5)
 969       wel_loc=weights(7)*fact(2)
 970       wturn3=weights(8)*fact(2)
 971       wturn4=weights(9)*fact(3)
 972       wturn6=weights(10)*fact(5)
 973       wtor=weights(13)*fact(1)
 974       wtor_d=weights(14)*fact(2)
 975       wsccor=weights(21)*fact(1)
 976
 977       return
 978       end subroutine rescale_weights
 979 !-----------------------------------------------------------------------------
 980       subroutine enerprint(energia)
 981 !      implicit real*8 (a-h,o-z)
 982 !      include 'DIMENSIONS'
 983 !      include 'COMMON.IOUNITS'
 984 !      include 'COMMON.FFIELD'
 985 !      include 'COMMON.SBRIDGE'
 986 !      include 'COMMON.MD'
 987       real(kind=8) :: energia(0:n_ene)
 988 !el local variables
 989       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 990       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 991       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 992        etube,ethetacnstr,Eafmforce
 993       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 994                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 995                       ecorr3_nucl
 996       real(kind=8) :: ecation_prot,ecationcation
 997       real(kind=8) :: escbase,epepbase,escpho,epeppho
 998
 999       etot=energia(0)
1000       evdw=energia(1)
1001       evdw2=energia(2)
1002 #ifdef SCP14
1003       evdw2=energia(2)+energia(18)
1004 #else
1005       evdw2=energia(2)
1006 #endif
1007       ees=energia(3)
1008 #ifdef SPLITELE
1009       evdw1=energia(16)
1010 #endif
1011       ecorr=energia(4)
1012       ecorr5=energia(5)
1013       ecorr6=energia(6)
1014       eel_loc=energia(7)
1015       eello_turn3=energia(8)
1016       eello_turn4=energia(9)
1017       eello_turn6=energia(10)
1018       ebe=energia(11)
1019       escloc=energia(12)
1020       etors=energia(13)
1021       etors_d=energia(14)
1022       ehpb=energia(15)
1023       edihcnstr=energia(19)
1024       estr=energia(17)
1025       Uconst=energia(20)
1026       esccor=energia(21)
1027       eliptran=energia(22)
1028       Eafmforce=energia(23)
1029       ethetacnstr=energia(24)
1030       etube=energia(25)
1031       evdwpp=energia(26)
1032       eespp=energia(27)
1033       evdwpsb=energia(28)
1034       eelpsb=energia(29)
1035       evdwsb=energia(30)
1036       eelsb=energia(31)
1037       estr_nucl=energia(32)
1038       ebe_nucl=energia(33)
1039       esbloc=energia(34)
1040       etors_nucl=energia(35)
1041       etors_d_nucl=energia(36)
1042       ecorr_nucl=energia(37)
1043       ecorr3_nucl=energia(38)
1044       ecation_prot=energia(41)
1045       ecationcation=energia(42)
1046       escbase=energia(46)
1047       epepbase=energia(47)
1048       escpho=energia(48)
1049       epeppho=energia(49)
1050 #ifdef SPLITELE
1051       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1052         estr,wbond,ebe,wang,&
1053         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1054         ecorr,wcorr,&
1055         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1056         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1057         edihcnstr,ethetacnstr,ebr*nss,&
1058         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1059         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1060         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1061         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1062         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1063         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1064         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1065         etot
1066    10 format (/'Virtual-chain energies:'// &
1067        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1068        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1069        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1070        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1071        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1072        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1073        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1074        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1075        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1076        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1077        ' (SS bridges & dist. cnstr.)'/ &
1078        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1079        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1080        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1081        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1082        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1083        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1084        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1085        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1086        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1087        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1088        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1089        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1090        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1091        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1092        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1093        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1094        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1095        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1096        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1097        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1098        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1099        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1100        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1101        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1102        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1103        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1104        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1105        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1106        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1107        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1108        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1109        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1110        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1111        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1112        'ETOT=  ',1pE16.6,' (total)')
1113 #else
1114       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1115         estr,wbond,ebe,wang,&
1116         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1117         ecorr,wcorr,&
1118         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1119         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1120         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1121         etube,wtube, &
1122         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1123         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1124         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1125         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1126         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1127         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1128         etot
1129    10 format (/'Virtual-chain energies:'// &
1130        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1131        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1132        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1133        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1134        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1135        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1136        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1137        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1138        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1139        ' (SS bridges & dist. cnstr.)'/ &
1140        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1141        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1142        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1143        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1144        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1145        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1146        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1147        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1148        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1149        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1150        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1151        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1152        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1153        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1154        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1155        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1156        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1157        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1158        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1159        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1160        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1161        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1162        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1163        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1164        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1165        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1166        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1167        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1168        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1169        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1170        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1171        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1172        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1173        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1174        'ETOT=  ',1pE16.6,' (total)')
1175 #endif
1176       return
1177       end subroutine enerprint
1178 !-----------------------------------------------------------------------------
1179       subroutine elj(evdw)
1180 !
1181 ! This subroutine calculates the interaction energy of nonbonded side chains
1182 ! assuming the LJ potential of interaction.
1183 !
1184 !      implicit real*8 (a-h,o-z)
1185 !      include 'DIMENSIONS'
1186       real(kind=8),parameter :: accur=1.0d-10
1187 !      include 'COMMON.GEO'
1188 !      include 'COMMON.VAR'
1189 !      include 'COMMON.LOCAL'
1190 !      include 'COMMON.CHAIN'
1191 !      include 'COMMON.DERIV'
1192 !      include 'COMMON.INTERACT'
1193 !      include 'COMMON.TORSION'
1194 !      include 'COMMON.SBRIDGE'
1195 !      include 'COMMON.NAMES'
1196 !      include 'COMMON.IOUNITS'
1197 !      include 'COMMON.CONTACTS'
1198       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1199       integer :: num_conti
1200 !el local variables
1201       integer :: i,itypi,iint,j,itypi1,itypj,k
1202       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1203       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1204       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1205
1206 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1207       evdw=0.0D0
1208 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1209 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1210 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1211 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1212
1213       do i=iatsc_s,iatsc_e
1214         itypi=iabs(itype(i,1))
1215         if (itypi.eq.ntyp1) cycle
1216         itypi1=iabs(itype(i+1,1))
1217         xi=c(1,nres+i)
1218         yi=c(2,nres+i)
1219         zi=c(3,nres+i)
1220 ! Change 12/1/95
1221         num_conti=0
1222 !
1223 ! Calculate SC interaction energy.
1224 !
1225         do iint=1,nint_gr(i)
1226 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1227 !d   &                  'iend=',iend(i,iint)
1228           do j=istart(i,iint),iend(i,iint)
1229             itypj=iabs(itype(j,1))
1230             if (itypj.eq.ntyp1) cycle
1231             xj=c(1,nres+j)-xi
1232             yj=c(2,nres+j)-yi
1233             zj=c(3,nres+j)-zi
1234 ! Change 12/1/95 to calculate four-body interactions
1235             rij=xj*xj+yj*yj+zj*zj
1236             rrij=1.0D0/rij
1237 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1238             eps0ij=eps(itypi,itypj)
1239             fac=rrij**expon2
1240             e1=fac*fac*aa_aq(itypi,itypj)
1241             e2=fac*bb_aq(itypi,itypj)
1242             evdwij=e1+e2
1243 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1244 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1245 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1246 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1247 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1248 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1249             evdw=evdw+evdwij
1250 !
1251 ! Calculate the components of the gradient in DC and X
1252 !
1253             fac=-rrij*(e1+evdwij)
1254             gg(1)=xj*fac
1255             gg(2)=yj*fac
1256             gg(3)=zj*fac
1257             do k=1,3
1258               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1259               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1260               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1261               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1262             enddo
1263 !grad            do k=i,j-1
1264 !grad              do l=1,3
1265 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1266 !grad              enddo
1267 !grad            enddo
1268 !
1269 ! 12/1/95, revised on 5/20/97
1270 !
1271 ! Calculate the contact function. The ith column of the array JCONT will
1272 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1273 ! greater than I). The arrays FACONT and GACONT will contain the values of
1274 ! the contact function and its derivative.
1275 !
1276 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1277 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1278 ! Uncomment next line, if the correlation interactions are contact function only
1279             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1280               rij=dsqrt(rij)
1281               sigij=sigma(itypi,itypj)
1282               r0ij=rs0(itypi,itypj)
1283 !
1284 ! Check whether the SC's are not too far to make a contact.
1285 !
1286               rcut=1.5d0*r0ij
1287               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1288 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1289 !
1290               if (fcont.gt.0.0D0) then
1291 ! If the SC-SC distance if close to sigma, apply spline.
1292 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1293 !Adam &             fcont1,fprimcont1)
1294 !Adam           fcont1=1.0d0-fcont1
1295 !Adam           if (fcont1.gt.0.0d0) then
1296 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1297 !Adam             fcont=fcont*fcont1
1298 !Adam           endif
1299 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1300 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1301 !ga             do k=1,3
1302 !ga               gg(k)=gg(k)*eps0ij
1303 !ga             enddo
1304 !ga             eps0ij=-evdwij*eps0ij
1305 ! Uncomment for AL's type of SC correlation interactions.
1306 !adam           eps0ij=-evdwij
1307                 num_conti=num_conti+1
1308                 jcont(num_conti,i)=j
1309                 facont(num_conti,i)=fcont*eps0ij
1310                 fprimcont=eps0ij*fprimcont/rij
1311                 fcont=expon*fcont
1312 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1313 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1314 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1315 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1316                 gacont(1,num_conti,i)=-fprimcont*xj
1317                 gacont(2,num_conti,i)=-fprimcont*yj
1318                 gacont(3,num_conti,i)=-fprimcont*zj
1319 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1320 !d              write (iout,'(2i3,3f10.5)')
1321 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1322               endif
1323             endif
1324           enddo      ! j
1325         enddo        ! iint
1326 ! Change 12/1/95
1327         num_cont(i)=num_conti
1328       enddo          ! i
1329       do i=1,nct
1330         do j=1,3
1331           gvdwc(j,i)=expon*gvdwc(j,i)
1332           gvdwx(j,i)=expon*gvdwx(j,i)
1333         enddo
1334       enddo
1335 !******************************************************************************
1336 !
1337 !                              N O T E !!!
1338 !
1339 ! To save time, the factor of EXPON has been extracted from ALL components
1340 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1341 ! use!
1342 !
1343 !******************************************************************************
1344       return
1345       end subroutine elj
1346 !-----------------------------------------------------------------------------
1347       subroutine eljk(evdw)
1348 !
1349 ! This subroutine calculates the interaction energy of nonbonded side chains
1350 ! assuming the LJK potential of interaction.
1351 !
1352 !      implicit real*8 (a-h,o-z)
1353 !      include 'DIMENSIONS'
1354 !      include 'COMMON.GEO'
1355 !      include 'COMMON.VAR'
1356 !      include 'COMMON.LOCAL'
1357 !      include 'COMMON.CHAIN'
1358 !      include 'COMMON.DERIV'
1359 !      include 'COMMON.INTERACT'
1360 !      include 'COMMON.IOUNITS'
1361 !      include 'COMMON.NAMES'
1362       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1363       logical :: scheck
1364 !el local variables
1365       integer :: i,iint,j,itypi,itypi1,k,itypj
1366       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1367       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1368
1369 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1370       evdw=0.0D0
1371       do i=iatsc_s,iatsc_e
1372         itypi=iabs(itype(i,1))
1373         if (itypi.eq.ntyp1) cycle
1374         itypi1=iabs(itype(i+1,1))
1375         xi=c(1,nres+i)
1376         yi=c(2,nres+i)
1377         zi=c(3,nres+i)
1378 !
1379 ! Calculate SC interaction energy.
1380 !
1381         do iint=1,nint_gr(i)
1382           do j=istart(i,iint),iend(i,iint)
1383             itypj=iabs(itype(j,1))
1384             if (itypj.eq.ntyp1) cycle
1385             xj=c(1,nres+j)-xi
1386             yj=c(2,nres+j)-yi
1387             zj=c(3,nres+j)-zi
1388             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1389             fac_augm=rrij**expon
1390             e_augm=augm(itypi,itypj)*fac_augm
1391             r_inv_ij=dsqrt(rrij)
1392             rij=1.0D0/r_inv_ij
1393             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1394             fac=r_shift_inv**expon
1395             e1=fac*fac*aa_aq(itypi,itypj)
1396             e2=fac*bb_aq(itypi,itypj)
1397             evdwij=e_augm+e1+e2
1398 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1399 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1400 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1401 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1402 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1403 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1404 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1405             evdw=evdw+evdwij
1406 !
1407 ! Calculate the components of the gradient in DC and X
1408 !
1409             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1410             gg(1)=xj*fac
1411             gg(2)=yj*fac
1412             gg(3)=zj*fac
1413             do k=1,3
1414               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1415               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1416               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1417               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1418             enddo
1419 !grad            do k=i,j-1
1420 !grad              do l=1,3
1421 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1422 !grad              enddo
1423 !grad            enddo
1424           enddo      ! j
1425         enddo        ! iint
1426       enddo          ! i
1427       do i=1,nct
1428         do j=1,3
1429           gvdwc(j,i)=expon*gvdwc(j,i)
1430           gvdwx(j,i)=expon*gvdwx(j,i)
1431         enddo
1432       enddo
1433       return
1434       end subroutine eljk
1435 !-----------------------------------------------------------------------------
1436       subroutine ebp(evdw)
1437 !
1438 ! This subroutine calculates the interaction energy of nonbonded side chains
1439 ! assuming the Berne-Pechukas potential of interaction.
1440 !
1441       use comm_srutu
1442       use calc_data
1443 !      implicit real*8 (a-h,o-z)
1444 !      include 'DIMENSIONS'
1445 !      include 'COMMON.GEO'
1446 !      include 'COMMON.VAR'
1447 !      include 'COMMON.LOCAL'
1448 !      include 'COMMON.CHAIN'
1449 !      include 'COMMON.DERIV'
1450 !      include 'COMMON.NAMES'
1451 !      include 'COMMON.INTERACT'
1452 !      include 'COMMON.IOUNITS'
1453 !      include 'COMMON.CALC'
1454       use comm_srutu
1455 !el      integer :: icall
1456 !el      common /srutu/ icall
1457 !     double precision rrsave(maxdim)
1458       logical :: lprn
1459 !el local variables
1460       integer :: iint,itypi,itypi1,itypj
1461       real(kind=8) :: rrij,xi,yi,zi
1462       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1463
1464 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1465       evdw=0.0D0
1466 !     if (icall.eq.0) then
1467 !       lprn=.true.
1468 !     else
1469         lprn=.false.
1470 !     endif
1471 !el      ind=0
1472       do i=iatsc_s,iatsc_e
1473         itypi=iabs(itype(i,1))
1474         if (itypi.eq.ntyp1) cycle
1475         itypi1=iabs(itype(i+1,1))
1476         xi=c(1,nres+i)
1477         yi=c(2,nres+i)
1478         zi=c(3,nres+i)
1479         dxi=dc_norm(1,nres+i)
1480         dyi=dc_norm(2,nres+i)
1481         dzi=dc_norm(3,nres+i)
1482 !        dsci_inv=dsc_inv(itypi)
1483         dsci_inv=vbld_inv(i+nres)
1484 !
1485 ! Calculate SC interaction energy.
1486 !
1487         do iint=1,nint_gr(i)
1488           do j=istart(i,iint),iend(i,iint)
1489 !el            ind=ind+1
1490             itypj=iabs(itype(j,1))
1491             if (itypj.eq.ntyp1) cycle
1492 !            dscj_inv=dsc_inv(itypj)
1493             dscj_inv=vbld_inv(j+nres)
1494             chi1=chi(itypi,itypj)
1495             chi2=chi(itypj,itypi)
1496             chi12=chi1*chi2
1497             chip1=chip(itypi)
1498             chip2=chip(itypj)
1499             chip12=chip1*chip2
1500             alf1=alp(itypi)
1501             alf2=alp(itypj)
1502             alf12=0.5D0*(alf1+alf2)
1503 ! For diagnostics only!!!
1504 !           chi1=0.0D0
1505 !           chi2=0.0D0
1506 !           chi12=0.0D0
1507 !           chip1=0.0D0
1508 !           chip2=0.0D0
1509 !           chip12=0.0D0
1510 !           alf1=0.0D0
1511 !           alf2=0.0D0
1512 !           alf12=0.0D0
1513             xj=c(1,nres+j)-xi
1514             yj=c(2,nres+j)-yi
1515             zj=c(3,nres+j)-zi
1516             dxj=dc_norm(1,nres+j)
1517             dyj=dc_norm(2,nres+j)
1518             dzj=dc_norm(3,nres+j)
1519             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1520 !d          if (icall.eq.0) then
1521 !d            rrsave(ind)=rrij
1522 !d          else
1523 !d            rrij=rrsave(ind)
1524 !d          endif
1525             rij=dsqrt(rrij)
1526 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1527             call sc_angular
1528 ! Calculate whole angle-dependent part of epsilon and contributions
1529 ! to its derivatives
1530             fac=(rrij*sigsq)**expon2
1531             e1=fac*fac*aa_aq(itypi,itypj)
1532             e2=fac*bb_aq(itypi,itypj)
1533             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1534             eps2der=evdwij*eps3rt
1535             eps3der=evdwij*eps2rt
1536             evdwij=evdwij*eps2rt*eps3rt
1537             evdw=evdw+evdwij
1538             if (lprn) then
1539             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1540             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1541 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1542 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1543 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1544 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1545 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1546 !d     &        evdwij
1547             endif
1548 ! Calculate gradient components.
1549             e1=e1*eps1*eps2rt**2*eps3rt**2
1550             fac=-expon*(e1+evdwij)
1551             sigder=fac/sigsq
1552             fac=rrij*fac
1553 ! Calculate radial part of the gradient
1554             gg(1)=xj*fac
1555             gg(2)=yj*fac
1556             gg(3)=zj*fac
1557 ! Calculate the angular part of the gradient and sum add the contributions
1558 ! to the appropriate components of the Cartesian gradient.
1559             call sc_grad
1560           enddo      ! j
1561         enddo        ! iint
1562       enddo          ! i
1563 !     stop
1564       return
1565       end subroutine ebp
1566 !-----------------------------------------------------------------------------
1567       subroutine egb(evdw)
1568 !
1569 ! This subroutine calculates the interaction energy of nonbonded side chains
1570 ! assuming the Gay-Berne potential of interaction.
1571 !
1572       use calc_data
1573 !      implicit real*8 (a-h,o-z)
1574 !      include 'DIMENSIONS'
1575 !      include 'COMMON.GEO'
1576 !      include 'COMMON.VAR'
1577 !      include 'COMMON.LOCAL'
1578 !      include 'COMMON.CHAIN'
1579 !      include 'COMMON.DERIV'
1580 !      include 'COMMON.NAMES'
1581 !      include 'COMMON.INTERACT'
1582 !      include 'COMMON.IOUNITS'
1583 !      include 'COMMON.CALC'
1584 !      include 'COMMON.CONTROL'
1585 !      include 'COMMON.SBRIDGE'
1586       logical :: lprn
1587 !el local variables
1588       integer :: iint,itypi,itypi1,itypj,subchap
1589       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1590       real(kind=8) :: evdw,sig0ij
1591       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1592                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1593                     sslipi,sslipj,faclip
1594       integer :: ii
1595       real(kind=8) :: fracinbuf
1596
1597 !cccc      energy_dec=.false.
1598 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1599       evdw=0.0D0
1600       lprn=.false.
1601 !     if (icall.eq.0) lprn=.false.
1602 !el      ind=0
1603       do i=iatsc_s,iatsc_e
1604 !C        print *,"I am in EVDW",i
1605         itypi=iabs(itype(i,1))
1606 !        if (i.ne.47) cycle
1607         if (itypi.eq.ntyp1) cycle
1608         itypi1=iabs(itype(i+1,1))
1609         xi=c(1,nres+i)
1610         yi=c(2,nres+i)
1611         zi=c(3,nres+i)
1612           xi=dmod(xi,boxxsize)
1613           if (xi.lt.0) xi=xi+boxxsize
1614           yi=dmod(yi,boxysize)
1615           if (yi.lt.0) yi=yi+boxysize
1616           zi=dmod(zi,boxzsize)
1617           if (zi.lt.0) zi=zi+boxzsize
1618
1619        if ((zi.gt.bordlipbot)  &
1620         .and.(zi.lt.bordliptop)) then
1621 !C the energy transfer exist
1622         if (zi.lt.buflipbot) then
1623 !C what fraction I am in
1624          fracinbuf=1.0d0-  &
1625               ((zi-bordlipbot)/lipbufthick)
1626 !C lipbufthick is thickenes of lipid buffore
1627          sslipi=sscalelip(fracinbuf)
1628          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1629         elseif (zi.gt.bufliptop) then
1630          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1631          sslipi=sscalelip(fracinbuf)
1632          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1633         else
1634          sslipi=1.0d0
1635          ssgradlipi=0.0
1636         endif
1637        else
1638          sslipi=0.0d0
1639          ssgradlipi=0.0
1640        endif
1641 !       print *, sslipi,ssgradlipi
1642         dxi=dc_norm(1,nres+i)
1643         dyi=dc_norm(2,nres+i)
1644         dzi=dc_norm(3,nres+i)
1645 !        dsci_inv=dsc_inv(itypi)
1646         dsci_inv=vbld_inv(i+nres)
1647 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1648 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1649 !
1650 ! Calculate SC interaction energy.
1651 !
1652         do iint=1,nint_gr(i)
1653           do j=istart(i,iint),iend(i,iint)
1654             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1655               call dyn_ssbond_ene(i,j,evdwij)
1656               evdw=evdw+evdwij
1657               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1658                               'evdw',i,j,evdwij,' ss'
1659 !              if (energy_dec) write (iout,*) &
1660 !                              'evdw',i,j,evdwij,' ss'
1661              do k=j+1,iend(i,iint)
1662 !C search over all next residues
1663               if (dyn_ss_mask(k)) then
1664 !C check if they are cysteins
1665 !C              write(iout,*) 'k=',k
1666
1667 !c              write(iout,*) "PRZED TRI", evdwij
1668 !               evdwij_przed_tri=evdwij
1669               call triple_ssbond_ene(i,j,k,evdwij)
1670 !c               if(evdwij_przed_tri.ne.evdwij) then
1671 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1672 !c               endif
1673
1674 !c              write(iout,*) "PO TRI", evdwij
1675 !C call the energy function that removes the artifical triple disulfide
1676 !C bond the soubroutine is located in ssMD.F
1677               evdw=evdw+evdwij
1678               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1679                             'evdw',i,j,evdwij,'tss'
1680               endif!dyn_ss_mask(k)
1681              enddo! k
1682             ELSE
1683 !el            ind=ind+1
1684             itypj=iabs(itype(j,1))
1685             if (itypj.eq.ntyp1) cycle
1686 !             if (j.ne.78) cycle
1687 !            dscj_inv=dsc_inv(itypj)
1688             dscj_inv=vbld_inv(j+nres)
1689 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1690 !              1.0d0/vbld(j+nres) !d
1691 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1692             sig0ij=sigma(itypi,itypj)
1693             chi1=chi(itypi,itypj)
1694             chi2=chi(itypj,itypi)
1695             chi12=chi1*chi2
1696             chip1=chip(itypi)
1697             chip2=chip(itypj)
1698             chip12=chip1*chip2
1699             alf1=alp(itypi)
1700             alf2=alp(itypj)
1701             alf12=0.5D0*(alf1+alf2)
1702 ! For diagnostics only!!!
1703 !           chi1=0.0D0
1704 !           chi2=0.0D0
1705 !           chi12=0.0D0
1706 !           chip1=0.0D0
1707 !           chip2=0.0D0
1708 !           chip12=0.0D0
1709 !           alf1=0.0D0
1710 !           alf2=0.0D0
1711 !           alf12=0.0D0
1712            xj=c(1,nres+j)
1713            yj=c(2,nres+j)
1714            zj=c(3,nres+j)
1715           xj=dmod(xj,boxxsize)
1716           if (xj.lt.0) xj=xj+boxxsize
1717           yj=dmod(yj,boxysize)
1718           if (yj.lt.0) yj=yj+boxysize
1719           zj=dmod(zj,boxzsize)
1720           if (zj.lt.0) zj=zj+boxzsize
1721 !          print *,"tu",xi,yi,zi,xj,yj,zj
1722 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1723 ! this fragment set correct epsilon for lipid phase
1724        if ((zj.gt.bordlipbot)  &
1725        .and.(zj.lt.bordliptop)) then
1726 !C the energy transfer exist
1727         if (zj.lt.buflipbot) then
1728 !C what fraction I am in
1729          fracinbuf=1.0d0-     &
1730              ((zj-bordlipbot)/lipbufthick)
1731 !C lipbufthick is thickenes of lipid buffore
1732          sslipj=sscalelip(fracinbuf)
1733          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1734         elseif (zj.gt.bufliptop) then
1735          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1736          sslipj=sscalelip(fracinbuf)
1737          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1738         else
1739          sslipj=1.0d0
1740          ssgradlipj=0.0
1741         endif
1742        else
1743          sslipj=0.0d0
1744          ssgradlipj=0.0
1745        endif
1746       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1747        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1748       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1749        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1750 !------------------------------------------------
1751       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1752       xj_safe=xj
1753       yj_safe=yj
1754       zj_safe=zj
1755       subchap=0
1756       do xshift=-1,1
1757       do yshift=-1,1
1758       do zshift=-1,1
1759           xj=xj_safe+xshift*boxxsize
1760           yj=yj_safe+yshift*boxysize
1761           zj=zj_safe+zshift*boxzsize
1762           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1763           if(dist_temp.lt.dist_init) then
1764             dist_init=dist_temp
1765             xj_temp=xj
1766             yj_temp=yj
1767             zj_temp=zj
1768             subchap=1
1769           endif
1770        enddo
1771        enddo
1772        enddo
1773        if (subchap.eq.1) then
1774           xj=xj_temp-xi
1775           yj=yj_temp-yi
1776           zj=zj_temp-zi
1777        else
1778           xj=xj_safe-xi
1779           yj=yj_safe-yi
1780           zj=zj_safe-zi
1781        endif
1782             dxj=dc_norm(1,nres+j)
1783             dyj=dc_norm(2,nres+j)
1784             dzj=dc_norm(3,nres+j)
1785 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1786 !            write (iout,*) "j",j," dc_norm",& !d
1787 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1788 !          write(iout,*)"rrij ",rrij
1789 !          write(iout,*)"xj yj zj ", xj, yj, zj
1790 !          write(iout,*)"xi yi zi ", xi, yi, zi
1791 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1792             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1793             rij=dsqrt(rrij)
1794             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1795             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1796 !            print *,sss_ele_cut,sss_ele_grad,&
1797 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1798             if (sss_ele_cut.le.0.0) cycle
1799 ! Calculate angle-dependent terms of energy and contributions to their
1800 ! derivatives.
1801             call sc_angular
1802             sigsq=1.0D0/sigsq
1803             sig=sig0ij*dsqrt(sigsq)
1804             rij_shift=1.0D0/rij-sig+sig0ij
1805 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1806 !            "sig0ij",sig0ij
1807 ! for diagnostics; uncomment
1808 !            rij_shift=1.2*sig0ij
1809 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1810             if (rij_shift.le.0.0D0) then
1811               evdw=1.0D20
1812 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1813 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1814 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1815               return
1816             endif
1817             sigder=-sig*sigsq
1818 !---------------------------------------------------------------
1819             rij_shift=1.0D0/rij_shift
1820             fac=rij_shift**expon
1821             faclip=fac
1822             e1=fac*fac*aa!(itypi,itypj)
1823             e2=fac*bb!(itypi,itypj)
1824             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1825             eps2der=evdwij*eps3rt
1826             eps3der=evdwij*eps2rt
1827 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1828 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1829 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1830             evdwij=evdwij*eps2rt*eps3rt
1831             evdw=evdw+evdwij*sss_ele_cut
1832             if (lprn) then
1833             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1834             epsi=bb**2/aa!(itypi,itypj)
1835             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1836               restyp(itypi,1),i,restyp(itypj,1),j, &
1837               epsi,sigm,chi1,chi2,chip1,chip2, &
1838               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1839               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1840               evdwij
1841             endif
1842
1843             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1844                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1845 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1846 !            if (energy_dec) write (iout,*) &
1847 !                             'evdw',i,j,evdwij
1848 !                       print *,"ZALAMKA", evdw
1849
1850 ! Calculate gradient components.
1851             e1=e1*eps1*eps2rt**2*eps3rt**2
1852             fac=-expon*(e1+evdwij)*rij_shift
1853             sigder=fac*sigder
1854             fac=rij*fac
1855 !            print *,'before fac',fac,rij,evdwij
1856             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1857             /sigma(itypi,itypj)*rij
1858 !            print *,'grad part scale',fac,   &
1859 !             evdwij*sss_ele_grad/sss_ele_cut &
1860 !            /sigma(itypi,itypj)*rij
1861 !            fac=0.0d0
1862 ! Calculate the radial part of the gradient
1863             gg(1)=xj*fac
1864             gg(2)=yj*fac
1865             gg(3)=zj*fac
1866 !C Calculate the radial part of the gradient
1867             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1868        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1869         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1870        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1871             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1872             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1873
1874 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1875 ! Calculate angular part of the gradient.
1876             call sc_grad
1877             ENDIF    ! dyn_ss
1878           enddo      ! j
1879         enddo        ! iint
1880       enddo          ! i
1881 !       print *,"ZALAMKA", evdw
1882 !      write (iout,*) "Number of loop steps in EGB:",ind
1883 !ccc      energy_dec=.false.
1884       return
1885       end subroutine egb
1886 !-----------------------------------------------------------------------------
1887       subroutine egbv(evdw)
1888 !
1889 ! This subroutine calculates the interaction energy of nonbonded side chains
1890 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1891 !
1892       use comm_srutu
1893       use calc_data
1894 !      implicit real*8 (a-h,o-z)
1895 !      include 'DIMENSIONS'
1896 !      include 'COMMON.GEO'
1897 !      include 'COMMON.VAR'
1898 !      include 'COMMON.LOCAL'
1899 !      include 'COMMON.CHAIN'
1900 !      include 'COMMON.DERIV'
1901 !      include 'COMMON.NAMES'
1902 !      include 'COMMON.INTERACT'
1903 !      include 'COMMON.IOUNITS'
1904 !      include 'COMMON.CALC'
1905       use comm_srutu
1906 !el      integer :: icall
1907 !el      common /srutu/ icall
1908       logical :: lprn
1909 !el local variables
1910       integer :: iint,itypi,itypi1,itypj
1911       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1912       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1913
1914 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1915       evdw=0.0D0
1916       lprn=.false.
1917 !     if (icall.eq.0) lprn=.true.
1918 !el      ind=0
1919       do i=iatsc_s,iatsc_e
1920         itypi=iabs(itype(i,1))
1921         if (itypi.eq.ntyp1) cycle
1922         itypi1=iabs(itype(i+1,1))
1923         xi=c(1,nres+i)
1924         yi=c(2,nres+i)
1925         zi=c(3,nres+i)
1926         dxi=dc_norm(1,nres+i)
1927         dyi=dc_norm(2,nres+i)
1928         dzi=dc_norm(3,nres+i)
1929 !        dsci_inv=dsc_inv(itypi)
1930         dsci_inv=vbld_inv(i+nres)
1931 !
1932 ! Calculate SC interaction energy.
1933 !
1934         do iint=1,nint_gr(i)
1935           do j=istart(i,iint),iend(i,iint)
1936 !el            ind=ind+1
1937             itypj=iabs(itype(j,1))
1938             if (itypj.eq.ntyp1) cycle
1939 !            dscj_inv=dsc_inv(itypj)
1940             dscj_inv=vbld_inv(j+nres)
1941             sig0ij=sigma(itypi,itypj)
1942             r0ij=r0(itypi,itypj)
1943             chi1=chi(itypi,itypj)
1944             chi2=chi(itypj,itypi)
1945             chi12=chi1*chi2
1946             chip1=chip(itypi)
1947             chip2=chip(itypj)
1948             chip12=chip1*chip2
1949             alf1=alp(itypi)
1950             alf2=alp(itypj)
1951             alf12=0.5D0*(alf1+alf2)
1952 ! For diagnostics only!!!
1953 !           chi1=0.0D0
1954 !           chi2=0.0D0
1955 !           chi12=0.0D0
1956 !           chip1=0.0D0
1957 !           chip2=0.0D0
1958 !           chip12=0.0D0
1959 !           alf1=0.0D0
1960 !           alf2=0.0D0
1961 !           alf12=0.0D0
1962             xj=c(1,nres+j)-xi
1963             yj=c(2,nres+j)-yi
1964             zj=c(3,nres+j)-zi
1965             dxj=dc_norm(1,nres+j)
1966             dyj=dc_norm(2,nres+j)
1967             dzj=dc_norm(3,nres+j)
1968             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1969             rij=dsqrt(rrij)
1970 ! Calculate angle-dependent terms of energy and contributions to their
1971 ! derivatives.
1972             call sc_angular
1973             sigsq=1.0D0/sigsq
1974             sig=sig0ij*dsqrt(sigsq)
1975             rij_shift=1.0D0/rij-sig+r0ij
1976 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1977             if (rij_shift.le.0.0D0) then
1978               evdw=1.0D20
1979               return
1980             endif
1981             sigder=-sig*sigsq
1982 !---------------------------------------------------------------
1983             rij_shift=1.0D0/rij_shift
1984             fac=rij_shift**expon
1985             e1=fac*fac*aa_aq(itypi,itypj)
1986             e2=fac*bb_aq(itypi,itypj)
1987             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1988             eps2der=evdwij*eps3rt
1989             eps3der=evdwij*eps2rt
1990             fac_augm=rrij**expon
1991             e_augm=augm(itypi,itypj)*fac_augm
1992             evdwij=evdwij*eps2rt*eps3rt
1993             evdw=evdw+evdwij+e_augm
1994             if (lprn) then
1995             sigm=dabs(aa_aq(itypi,itypj)/&
1996             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1997             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1998             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1999               restyp(itypi,1),i,restyp(itypj,1),j,&
2000               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2001               chi1,chi2,chip1,chip2,&
2002               eps1,eps2rt**2,eps3rt**2,&
2003               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2004               evdwij+e_augm
2005             endif
2006 ! Calculate gradient components.
2007             e1=e1*eps1*eps2rt**2*eps3rt**2
2008             fac=-expon*(e1+evdwij)*rij_shift
2009             sigder=fac*sigder
2010             fac=rij*fac-2*expon*rrij*e_augm
2011 ! Calculate the radial part of the gradient
2012             gg(1)=xj*fac
2013             gg(2)=yj*fac
2014             gg(3)=zj*fac
2015 ! Calculate angular part of the gradient.
2016             call sc_grad
2017           enddo      ! j
2018         enddo        ! iint
2019       enddo          ! i
2020       end subroutine egbv
2021 !-----------------------------------------------------------------------------
2022 !el      subroutine sc_angular in module geometry
2023 !-----------------------------------------------------------------------------
2024       subroutine e_softsphere(evdw)
2025 !
2026 ! This subroutine calculates the interaction energy of nonbonded side chains
2027 ! assuming the LJ potential of interaction.
2028 !
2029 !      implicit real*8 (a-h,o-z)
2030 !      include 'DIMENSIONS'
2031       real(kind=8),parameter :: accur=1.0d-10
2032 !      include 'COMMON.GEO'
2033 !      include 'COMMON.VAR'
2034 !      include 'COMMON.LOCAL'
2035 !      include 'COMMON.CHAIN'
2036 !      include 'COMMON.DERIV'
2037 !      include 'COMMON.INTERACT'
2038 !      include 'COMMON.TORSION'
2039 !      include 'COMMON.SBRIDGE'
2040 !      include 'COMMON.NAMES'
2041 !      include 'COMMON.IOUNITS'
2042 !      include 'COMMON.CONTACTS'
2043       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2044 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2045 !el local variables
2046       integer :: i,iint,j,itypi,itypi1,itypj,k
2047       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2048       real(kind=8) :: fac
2049
2050       evdw=0.0D0
2051       do i=iatsc_s,iatsc_e
2052         itypi=iabs(itype(i,1))
2053         if (itypi.eq.ntyp1) cycle
2054         itypi1=iabs(itype(i+1,1))
2055         xi=c(1,nres+i)
2056         yi=c(2,nres+i)
2057         zi=c(3,nres+i)
2058 !
2059 ! Calculate SC interaction energy.
2060 !
2061         do iint=1,nint_gr(i)
2062 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2063 !d   &                  'iend=',iend(i,iint)
2064           do j=istart(i,iint),iend(i,iint)
2065             itypj=iabs(itype(j,1))
2066             if (itypj.eq.ntyp1) cycle
2067             xj=c(1,nres+j)-xi
2068             yj=c(2,nres+j)-yi
2069             zj=c(3,nres+j)-zi
2070             rij=xj*xj+yj*yj+zj*zj
2071 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2072             r0ij=r0(itypi,itypj)
2073             r0ijsq=r0ij*r0ij
2074 !            print *,i,j,r0ij,dsqrt(rij)
2075             if (rij.lt.r0ijsq) then
2076               evdwij=0.25d0*(rij-r0ijsq)**2
2077               fac=rij-r0ijsq
2078             else
2079               evdwij=0.0d0
2080               fac=0.0d0
2081             endif
2082             evdw=evdw+evdwij
2083 !
2084 ! Calculate the components of the gradient in DC and X
2085 !
2086             gg(1)=xj*fac
2087             gg(2)=yj*fac
2088             gg(3)=zj*fac
2089             do k=1,3
2090               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2091               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2092               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2093               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2094             enddo
2095 !grad            do k=i,j-1
2096 !grad              do l=1,3
2097 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2098 !grad              enddo
2099 !grad            enddo
2100           enddo ! j
2101         enddo ! iint
2102       enddo ! i
2103       return
2104       end subroutine e_softsphere
2105 !-----------------------------------------------------------------------------
2106       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2107 !
2108 ! Soft-sphere potential of p-p interaction
2109 !
2110 !      implicit real*8 (a-h,o-z)
2111 !      include 'DIMENSIONS'
2112 !      include 'COMMON.CONTROL'
2113 !      include 'COMMON.IOUNITS'
2114 !      include 'COMMON.GEO'
2115 !      include 'COMMON.VAR'
2116 !      include 'COMMON.LOCAL'
2117 !      include 'COMMON.CHAIN'
2118 !      include 'COMMON.DERIV'
2119 !      include 'COMMON.INTERACT'
2120 !      include 'COMMON.CONTACTS'
2121 !      include 'COMMON.TORSION'
2122 !      include 'COMMON.VECTORS'
2123 !      include 'COMMON.FFIELD'
2124       real(kind=8),dimension(3) :: ggg
2125 !d      write(iout,*) 'In EELEC_soft_sphere'
2126 !el local variables
2127       integer :: i,j,k,num_conti,iteli,itelj
2128       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2129       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2130       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2131
2132       ees=0.0D0
2133       evdw1=0.0D0
2134       eel_loc=0.0d0
2135       eello_turn3=0.0d0
2136       eello_turn4=0.0d0
2137 !el      ind=0
2138       do i=iatel_s,iatel_e
2139         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2140         dxi=dc(1,i)
2141         dyi=dc(2,i)
2142         dzi=dc(3,i)
2143         xmedi=c(1,i)+0.5d0*dxi
2144         ymedi=c(2,i)+0.5d0*dyi
2145         zmedi=c(3,i)+0.5d0*dzi
2146         num_conti=0
2147 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2148         do j=ielstart(i),ielend(i)
2149           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2150 !el          ind=ind+1
2151           iteli=itel(i)
2152           itelj=itel(j)
2153           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2154           r0ij=rpp(iteli,itelj)
2155           r0ijsq=r0ij*r0ij
2156           dxj=dc(1,j)
2157           dyj=dc(2,j)
2158           dzj=dc(3,j)
2159           xj=c(1,j)+0.5D0*dxj-xmedi
2160           yj=c(2,j)+0.5D0*dyj-ymedi
2161           zj=c(3,j)+0.5D0*dzj-zmedi
2162           rij=xj*xj+yj*yj+zj*zj
2163           if (rij.lt.r0ijsq) then
2164             evdw1ij=0.25d0*(rij-r0ijsq)**2
2165             fac=rij-r0ijsq
2166           else
2167             evdw1ij=0.0d0
2168             fac=0.0d0
2169           endif
2170           evdw1=evdw1+evdw1ij
2171 !
2172 ! Calculate contributions to the Cartesian gradient.
2173 !
2174           ggg(1)=fac*xj
2175           ggg(2)=fac*yj
2176           ggg(3)=fac*zj
2177           do k=1,3
2178             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2179             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2180           enddo
2181 !
2182 ! Loop over residues i+1 thru j-1.
2183 !
2184 !grad          do k=i+1,j-1
2185 !grad            do l=1,3
2186 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2187 !grad            enddo
2188 !grad          enddo
2189         enddo ! j
2190       enddo   ! i
2191 !grad      do i=nnt,nct-1
2192 !grad        do k=1,3
2193 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2194 !grad        enddo
2195 !grad        do j=i+1,nct-1
2196 !grad          do k=1,3
2197 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2198 !grad          enddo
2199 !grad        enddo
2200 !grad      enddo
2201       return
2202       end subroutine eelec_soft_sphere
2203 !-----------------------------------------------------------------------------
2204       subroutine vec_and_deriv
2205 !      implicit real*8 (a-h,o-z)
2206 !      include 'DIMENSIONS'
2207 #ifdef MPI
2208       include 'mpif.h'
2209 #endif
2210 !      include 'COMMON.IOUNITS'
2211 !      include 'COMMON.GEO'
2212 !      include 'COMMON.VAR'
2213 !      include 'COMMON.LOCAL'
2214 !      include 'COMMON.CHAIN'
2215 !      include 'COMMON.VECTORS'
2216 !      include 'COMMON.SETUP'
2217 !      include 'COMMON.TIME1'
2218       real(kind=8),dimension(3,3,2) :: uyder,uzder
2219       real(kind=8),dimension(2) :: vbld_inv_temp
2220 ! Compute the local reference systems. For reference system (i), the
2221 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2222 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2223 !el local variables
2224       integer :: i,j,k,l
2225       real(kind=8) :: facy,fac,costh
2226
2227 #ifdef PARVEC
2228       do i=ivec_start,ivec_end
2229 #else
2230       do i=1,nres-1
2231 #endif
2232           if (i.eq.nres-1) then
2233 ! Case of the last full residue
2234 ! Compute the Z-axis
2235             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2236             costh=dcos(pi-theta(nres))
2237             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2238             do k=1,3
2239               uz(k,i)=fac*uz(k,i)
2240             enddo
2241 ! Compute the derivatives of uz
2242             uzder(1,1,1)= 0.0d0
2243             uzder(2,1,1)=-dc_norm(3,i-1)
2244             uzder(3,1,1)= dc_norm(2,i-1)
2245             uzder(1,2,1)= dc_norm(3,i-1)
2246             uzder(2,2,1)= 0.0d0
2247             uzder(3,2,1)=-dc_norm(1,i-1)
2248             uzder(1,3,1)=-dc_norm(2,i-1)
2249             uzder(2,3,1)= dc_norm(1,i-1)
2250             uzder(3,3,1)= 0.0d0
2251             uzder(1,1,2)= 0.0d0
2252             uzder(2,1,2)= dc_norm(3,i)
2253             uzder(3,1,2)=-dc_norm(2,i)
2254             uzder(1,2,2)=-dc_norm(3,i)
2255             uzder(2,2,2)= 0.0d0
2256             uzder(3,2,2)= dc_norm(1,i)
2257             uzder(1,3,2)= dc_norm(2,i)
2258             uzder(2,3,2)=-dc_norm(1,i)
2259             uzder(3,3,2)= 0.0d0
2260 ! Compute the Y-axis
2261             facy=fac
2262             do k=1,3
2263               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2264             enddo
2265 ! Compute the derivatives of uy
2266             do j=1,3
2267               do k=1,3
2268                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2269                               -dc_norm(k,i)*dc_norm(j,i-1)
2270                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2271               enddo
2272               uyder(j,j,1)=uyder(j,j,1)-costh
2273               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2274             enddo
2275             do j=1,2
2276               do k=1,3
2277                 do l=1,3
2278                   uygrad(l,k,j,i)=uyder(l,k,j)
2279                   uzgrad(l,k,j,i)=uzder(l,k,j)
2280                 enddo
2281               enddo
2282             enddo
2283             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2284             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2285             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2286             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2287           else
2288 ! Other residues
2289 ! Compute the Z-axis
2290             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2291             costh=dcos(pi-theta(i+2))
2292             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2293             do k=1,3
2294               uz(k,i)=fac*uz(k,i)
2295             enddo
2296 ! Compute the derivatives of uz
2297             uzder(1,1,1)= 0.0d0
2298             uzder(2,1,1)=-dc_norm(3,i+1)
2299             uzder(3,1,1)= dc_norm(2,i+1)
2300             uzder(1,2,1)= dc_norm(3,i+1)
2301             uzder(2,2,1)= 0.0d0
2302             uzder(3,2,1)=-dc_norm(1,i+1)
2303             uzder(1,3,1)=-dc_norm(2,i+1)
2304             uzder(2,3,1)= dc_norm(1,i+1)
2305             uzder(3,3,1)= 0.0d0
2306             uzder(1,1,2)= 0.0d0
2307             uzder(2,1,2)= dc_norm(3,i)
2308             uzder(3,1,2)=-dc_norm(2,i)
2309             uzder(1,2,2)=-dc_norm(3,i)
2310             uzder(2,2,2)= 0.0d0
2311             uzder(3,2,2)= dc_norm(1,i)
2312             uzder(1,3,2)= dc_norm(2,i)
2313             uzder(2,3,2)=-dc_norm(1,i)
2314             uzder(3,3,2)= 0.0d0
2315 ! Compute the Y-axis
2316             facy=fac
2317             do k=1,3
2318               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2319             enddo
2320 ! Compute the derivatives of uy
2321             do j=1,3
2322               do k=1,3
2323                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2324                               -dc_norm(k,i)*dc_norm(j,i+1)
2325                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2326               enddo
2327               uyder(j,j,1)=uyder(j,j,1)-costh
2328               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2329             enddo
2330             do j=1,2
2331               do k=1,3
2332                 do l=1,3
2333                   uygrad(l,k,j,i)=uyder(l,k,j)
2334                   uzgrad(l,k,j,i)=uzder(l,k,j)
2335                 enddo
2336               enddo
2337             enddo
2338             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2339             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2340             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2341             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2342           endif
2343       enddo
2344       do i=1,nres-1
2345         vbld_inv_temp(1)=vbld_inv(i+1)
2346         if (i.lt.nres-1) then
2347           vbld_inv_temp(2)=vbld_inv(i+2)
2348           else
2349           vbld_inv_temp(2)=vbld_inv(i)
2350           endif
2351         do j=1,2
2352           do k=1,3
2353             do l=1,3
2354               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2355               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2356             enddo
2357           enddo
2358         enddo
2359       enddo
2360 #if defined(PARVEC) && defined(MPI)
2361       if (nfgtasks1.gt.1) then
2362         time00=MPI_Wtime()
2363 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2364 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2365 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2366         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2367          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2368          FG_COMM1,IERR)
2369         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2370          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2371          FG_COMM1,IERR)
2372         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2373          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2374          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2375         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2376          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2377          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2378         time_gather=time_gather+MPI_Wtime()-time00
2379       endif
2380 !      if (fg_rank.eq.0) then
2381 !        write (iout,*) "Arrays UY and UZ"
2382 !        do i=1,nres-1
2383 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2384 !     &     (uz(k,i),k=1,3)
2385 !        enddo
2386 !      endif
2387 #endif
2388       return
2389       end subroutine vec_and_deriv
2390 !-----------------------------------------------------------------------------
2391       subroutine check_vecgrad
2392 !      implicit real*8 (a-h,o-z)
2393 !      include 'DIMENSIONS'
2394 !      include 'COMMON.IOUNITS'
2395 !      include 'COMMON.GEO'
2396 !      include 'COMMON.VAR'
2397 !      include 'COMMON.LOCAL'
2398 !      include 'COMMON.CHAIN'
2399 !      include 'COMMON.VECTORS'
2400       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2401       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2402       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2403       real(kind=8),dimension(3) :: erij
2404       real(kind=8) :: delta=1.0d-7
2405 !el local variables
2406       integer :: i,j,k,l
2407
2408       call vec_and_deriv
2409 !d      do i=1,nres
2410 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2411 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2412 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2413 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2414 !d     &     (dc_norm(if90,i),if90=1,3)
2415 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2416 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2417 !d          write(iout,'(a)')
2418 !d      enddo
2419       do i=1,nres
2420         do j=1,2
2421           do k=1,3
2422             do l=1,3
2423               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2424               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2425             enddo
2426           enddo
2427         enddo
2428       enddo
2429       call vec_and_deriv
2430       do i=1,nres
2431         do j=1,3
2432           uyt(j,i)=uy(j,i)
2433           uzt(j,i)=uz(j,i)
2434         enddo
2435       enddo
2436       do i=1,nres
2437 !d        write (iout,*) 'i=',i
2438         do k=1,3
2439           erij(k)=dc_norm(k,i)
2440         enddo
2441         do j=1,3
2442           do k=1,3
2443             dc_norm(k,i)=erij(k)
2444           enddo
2445           dc_norm(j,i)=dc_norm(j,i)+delta
2446 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2447 !          do k=1,3
2448 !            dc_norm(k,i)=dc_norm(k,i)/fac
2449 !          enddo
2450 !          write (iout,*) (dc_norm(k,i),k=1,3)
2451 !          write (iout,*) (erij(k),k=1,3)
2452           call vec_and_deriv
2453           do k=1,3
2454             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2455             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2456             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2457             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2458           enddo
2459 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2460 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2461 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2462         enddo
2463         do k=1,3
2464           dc_norm(k,i)=erij(k)
2465         enddo
2466 !d        do k=1,3
2467 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2468 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2469 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2470 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2471 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2472 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2473 !d          write (iout,'(a)')
2474 !d        enddo
2475       enddo
2476       return
2477       end subroutine check_vecgrad
2478 !-----------------------------------------------------------------------------
2479       subroutine set_matrices
2480 !      implicit real*8 (a-h,o-z)
2481 !      include 'DIMENSIONS'
2482 #ifdef MPI
2483       include "mpif.h"
2484 !      include "COMMON.SETUP"
2485       integer :: IERR
2486       integer :: status(MPI_STATUS_SIZE)
2487 #endif
2488 !      include 'COMMON.IOUNITS'
2489 !      include 'COMMON.GEO'
2490 !      include 'COMMON.VAR'
2491 !      include 'COMMON.LOCAL'
2492 !      include 'COMMON.CHAIN'
2493 !      include 'COMMON.DERIV'
2494 !      include 'COMMON.INTERACT'
2495 !      include 'COMMON.CONTACTS'
2496 !      include 'COMMON.TORSION'
2497 !      include 'COMMON.VECTORS'
2498 !      include 'COMMON.FFIELD'
2499       real(kind=8) :: auxvec(2),auxmat(2,2)
2500       integer :: i,iti1,iti,k,l
2501       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2502 !       print *,"in set matrices"
2503 !
2504 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2505 ! to calculate the el-loc multibody terms of various order.
2506 !
2507 !AL el      mu=0.0d0
2508 #ifdef PARMAT
2509       do i=ivec_start+2,ivec_end+2
2510 #else
2511       do i=3,nres+1
2512 #endif
2513 !      print *,i,"i"
2514         if (i .lt. nres+1) then
2515           sin1=dsin(phi(i))
2516           cos1=dcos(phi(i))
2517           sintab(i-2)=sin1
2518           costab(i-2)=cos1
2519           obrot(1,i-2)=cos1
2520           obrot(2,i-2)=sin1
2521           sin2=dsin(2*phi(i))
2522           cos2=dcos(2*phi(i))
2523           sintab2(i-2)=sin2
2524           costab2(i-2)=cos2
2525           obrot2(1,i-2)=cos2
2526           obrot2(2,i-2)=sin2
2527           Ug(1,1,i-2)=-cos1
2528           Ug(1,2,i-2)=-sin1
2529           Ug(2,1,i-2)=-sin1
2530           Ug(2,2,i-2)= cos1
2531           Ug2(1,1,i-2)=-cos2
2532           Ug2(1,2,i-2)=-sin2
2533           Ug2(2,1,i-2)=-sin2
2534           Ug2(2,2,i-2)= cos2
2535         else
2536           costab(i-2)=1.0d0
2537           sintab(i-2)=0.0d0
2538           obrot(1,i-2)=1.0d0
2539           obrot(2,i-2)=0.0d0
2540           obrot2(1,i-2)=0.0d0
2541           obrot2(2,i-2)=0.0d0
2542           Ug(1,1,i-2)=1.0d0
2543           Ug(1,2,i-2)=0.0d0
2544           Ug(2,1,i-2)=0.0d0
2545           Ug(2,2,i-2)=1.0d0
2546           Ug2(1,1,i-2)=0.0d0
2547           Ug2(1,2,i-2)=0.0d0
2548           Ug2(2,1,i-2)=0.0d0
2549           Ug2(2,2,i-2)=0.0d0
2550         endif
2551         if (i .gt. 3 .and. i .lt. nres+1) then
2552           obrot_der(1,i-2)=-sin1
2553           obrot_der(2,i-2)= cos1
2554           Ugder(1,1,i-2)= sin1
2555           Ugder(1,2,i-2)=-cos1
2556           Ugder(2,1,i-2)=-cos1
2557           Ugder(2,2,i-2)=-sin1
2558           dwacos2=cos2+cos2
2559           dwasin2=sin2+sin2
2560           obrot2_der(1,i-2)=-dwasin2
2561           obrot2_der(2,i-2)= dwacos2
2562           Ug2der(1,1,i-2)= dwasin2
2563           Ug2der(1,2,i-2)=-dwacos2
2564           Ug2der(2,1,i-2)=-dwacos2
2565           Ug2der(2,2,i-2)=-dwasin2
2566         else
2567           obrot_der(1,i-2)=0.0d0
2568           obrot_der(2,i-2)=0.0d0
2569           Ugder(1,1,i-2)=0.0d0
2570           Ugder(1,2,i-2)=0.0d0
2571           Ugder(2,1,i-2)=0.0d0
2572           Ugder(2,2,i-2)=0.0d0
2573           obrot2_der(1,i-2)=0.0d0
2574           obrot2_der(2,i-2)=0.0d0
2575           Ug2der(1,1,i-2)=0.0d0
2576           Ug2der(1,2,i-2)=0.0d0
2577           Ug2der(2,1,i-2)=0.0d0
2578           Ug2der(2,2,i-2)=0.0d0
2579         endif
2580 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2581         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2582            if (itype(i-2,1).eq.0) then
2583           iti=ntortyp+1
2584            else
2585           iti = itortyp(itype(i-2,1))
2586            endif
2587         else
2588           iti=ntortyp+1
2589         endif
2590 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2591         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2592            if (itype(i-1,1).eq.0) then
2593           iti1=ntortyp+1
2594            else
2595           iti1 = itortyp(itype(i-1,1))
2596            endif
2597         else
2598           iti1=ntortyp+1
2599         endif
2600 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2601 !d        write (iout,*) '*******i',i,' iti1',iti
2602 !d        write (iout,*) 'b1',b1(:,iti)
2603 !d        write (iout,*) 'b2',b2(:,iti)
2604 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2605 !        if (i .gt. iatel_s+2) then
2606         if (i .gt. nnt+2) then
2607           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2608           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2609           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2610           then
2611           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2612           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2613           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2614           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2615           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2616           endif
2617         else
2618           do k=1,2
2619             Ub2(k,i-2)=0.0d0
2620             Ctobr(k,i-2)=0.0d0
2621             Dtobr2(k,i-2)=0.0d0
2622             do l=1,2
2623               EUg(l,k,i-2)=0.0d0
2624               CUg(l,k,i-2)=0.0d0
2625               DUg(l,k,i-2)=0.0d0
2626               DtUg2(l,k,i-2)=0.0d0
2627             enddo
2628           enddo
2629         endif
2630         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2631         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2632         do k=1,2
2633           muder(k,i-2)=Ub2der(k,i-2)
2634         enddo
2635 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2636         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2637           if (itype(i-1,1).eq.0) then
2638            iti1=ntortyp+1
2639           elseif (itype(i-1,1).le.ntyp) then
2640             iti1 = itortyp(itype(i-1,1))
2641           else
2642             iti1=ntortyp+1
2643           endif
2644         else
2645           iti1=ntortyp+1
2646         endif
2647         do k=1,2
2648           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2649         enddo
2650 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2651 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2652 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2653 !d        write (iout,*) 'mu1',mu1(:,i-2)
2654 !d        write (iout,*) 'mu2',mu2(:,i-2)
2655         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2656         then
2657         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2658         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2659         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2660         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2661         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2662 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2663         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2664         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2665         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2666         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2667         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2668         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2669         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2670         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2671         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2672         endif
2673       enddo
2674 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2675 ! The order of matrices is from left to right.
2676       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2677       then
2678 !      do i=max0(ivec_start,2),ivec_end
2679       do i=2,nres-1
2680         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2681         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2682         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2683         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2684         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2685         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2686         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2687         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2688       enddo
2689       endif
2690 #if defined(MPI) && defined(PARMAT)
2691 #ifdef DEBUG
2692 !      if (fg_rank.eq.0) then
2693         write (iout,*) "Arrays UG and UGDER before GATHER"
2694         do i=1,nres-1
2695           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2696            ((ug(l,k,i),l=1,2),k=1,2),&
2697            ((ugder(l,k,i),l=1,2),k=1,2)
2698         enddo
2699         write (iout,*) "Arrays UG2 and UG2DER"
2700         do i=1,nres-1
2701           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2702            ((ug2(l,k,i),l=1,2),k=1,2),&
2703            ((ug2der(l,k,i),l=1,2),k=1,2)
2704         enddo
2705         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2706         do i=1,nres-1
2707           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2708            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2709            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2710         enddo
2711         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2712         do i=1,nres-1
2713           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2714            costab(i),sintab(i),costab2(i),sintab2(i)
2715         enddo
2716         write (iout,*) "Array MUDER"
2717         do i=1,nres-1
2718           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2719         enddo
2720 !      endif
2721 #endif
2722       if (nfgtasks.gt.1) then
2723         time00=MPI_Wtime()
2724 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2725 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2726 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2727 #ifdef MATGATHER
2728         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2729          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2730          FG_COMM1,IERR)
2731         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2732          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2733          FG_COMM1,IERR)
2734         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2735          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2736          FG_COMM1,IERR)
2737         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2738          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2739          FG_COMM1,IERR)
2740         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2741          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2742          FG_COMM1,IERR)
2743         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2744          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2745          FG_COMM1,IERR)
2746         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2747          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2748          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2749         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2750          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2751          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2752         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2753          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2754          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2755         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2756          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2757          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2758         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2759         then
2760         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2761          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2762          FG_COMM1,IERR)
2763         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2764          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2765          FG_COMM1,IERR)
2766         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2767          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2768          FG_COMM1,IERR)
2769        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2770          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2771          FG_COMM1,IERR)
2772         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2773          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2774          FG_COMM1,IERR)
2775         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2776          ivec_count(fg_rank1),&
2777          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2778          FG_COMM1,IERR)
2779         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2780          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2781          FG_COMM1,IERR)
2782         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2783          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2784          FG_COMM1,IERR)
2785         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2786          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2787          FG_COMM1,IERR)
2788         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2789          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2790          FG_COMM1,IERR)
2791         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2792          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2793          FG_COMM1,IERR)
2794         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2795          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2796          FG_COMM1,IERR)
2797         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2798          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2799          FG_COMM1,IERR)
2800         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2801          ivec_count(fg_rank1),&
2802          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2803          FG_COMM1,IERR)
2804         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2805          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2806          FG_COMM1,IERR)
2807        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2808          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2809          FG_COMM1,IERR)
2810         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2811          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2812          FG_COMM1,IERR)
2813        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2814          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2815          FG_COMM1,IERR)
2816         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2817          ivec_count(fg_rank1),&
2818          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2819          FG_COMM1,IERR)
2820         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2821          ivec_count(fg_rank1),&
2822          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2823          FG_COMM1,IERR)
2824         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2825          ivec_count(fg_rank1),&
2826          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2827          MPI_MAT2,FG_COMM1,IERR)
2828         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2829          ivec_count(fg_rank1),&
2830          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2831          MPI_MAT2,FG_COMM1,IERR)
2832         endif
2833 #else
2834 ! Passes matrix info through the ring
2835       isend=fg_rank1
2836       irecv=fg_rank1-1
2837       if (irecv.lt.0) irecv=nfgtasks1-1
2838       iprev=irecv
2839       inext=fg_rank1+1
2840       if (inext.ge.nfgtasks1) inext=0
2841       do i=1,nfgtasks1-1
2842 !        write (iout,*) "isend",isend," irecv",irecv
2843 !        call flush(iout)
2844         lensend=lentyp(isend)
2845         lenrecv=lentyp(irecv)
2846 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2847 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2848 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2849 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2850 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2851 !        write (iout,*) "Gather ROTAT1"
2852 !        call flush(iout)
2853 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2854 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2855 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2856 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2857 !        write (iout,*) "Gather ROTAT2"
2858 !        call flush(iout)
2859         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2860          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2861          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2862          iprev,4400+irecv,FG_COMM,status,IERR)
2863 !        write (iout,*) "Gather ROTAT_OLD"
2864 !        call flush(iout)
2865         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2866          MPI_PRECOMP11(lensend),inext,5500+isend,&
2867          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2868          iprev,5500+irecv,FG_COMM,status,IERR)
2869 !        write (iout,*) "Gather PRECOMP11"
2870 !        call flush(iout)
2871         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2872          MPI_PRECOMP12(lensend),inext,6600+isend,&
2873          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2874          iprev,6600+irecv,FG_COMM,status,IERR)
2875 !        write (iout,*) "Gather PRECOMP12"
2876 !        call flush(iout)
2877         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2878         then
2879         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2880          MPI_ROTAT2(lensend),inext,7700+isend,&
2881          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2882          iprev,7700+irecv,FG_COMM,status,IERR)
2883 !        write (iout,*) "Gather PRECOMP21"
2884 !        call flush(iout)
2885         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2886          MPI_PRECOMP22(lensend),inext,8800+isend,&
2887          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2888          iprev,8800+irecv,FG_COMM,status,IERR)
2889 !        write (iout,*) "Gather PRECOMP22"
2890 !        call flush(iout)
2891         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2892          MPI_PRECOMP23(lensend),inext,9900+isend,&
2893          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2894          MPI_PRECOMP23(lenrecv),&
2895          iprev,9900+irecv,FG_COMM,status,IERR)
2896 !        write (iout,*) "Gather PRECOMP23"
2897 !        call flush(iout)
2898         endif
2899         isend=irecv
2900         irecv=irecv-1
2901         if (irecv.lt.0) irecv=nfgtasks1-1
2902       enddo
2903 #endif
2904         time_gather=time_gather+MPI_Wtime()-time00
2905       endif
2906 #ifdef DEBUG
2907 !      if (fg_rank.eq.0) then
2908         write (iout,*) "Arrays UG and UGDER"
2909         do i=1,nres-1
2910           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2911            ((ug(l,k,i),l=1,2),k=1,2),&
2912            ((ugder(l,k,i),l=1,2),k=1,2)
2913         enddo
2914         write (iout,*) "Arrays UG2 and UG2DER"
2915         do i=1,nres-1
2916           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2917            ((ug2(l,k,i),l=1,2),k=1,2),&
2918            ((ug2der(l,k,i),l=1,2),k=1,2)
2919         enddo
2920         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2921         do i=1,nres-1
2922           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2923            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2924            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2925         enddo
2926         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2927         do i=1,nres-1
2928           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2929            costab(i),sintab(i),costab2(i),sintab2(i)
2930         enddo
2931         write (iout,*) "Array MUDER"
2932         do i=1,nres-1
2933           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2934         enddo
2935 !      endif
2936 #endif
2937 #endif
2938 !d      do i=1,nres
2939 !d        iti = itortyp(itype(i,1))
2940 !d        write (iout,*) i
2941 !d        do j=1,2
2942 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2943 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2944 !d        enddo
2945 !d      enddo
2946       return
2947       end subroutine set_matrices
2948 !-----------------------------------------------------------------------------
2949       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2950 !
2951 ! This subroutine calculates the average interaction energy and its gradient
2952 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2953 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2954 ! The potential depends both on the distance of peptide-group centers and on
2955 ! the orientation of the CA-CA virtual bonds.
2956 !
2957       use comm_locel
2958 !      implicit real*8 (a-h,o-z)
2959 #ifdef MPI
2960       include 'mpif.h'
2961 #endif
2962 !      include 'DIMENSIONS'
2963 !      include 'COMMON.CONTROL'
2964 !      include 'COMMON.SETUP'
2965 !      include 'COMMON.IOUNITS'
2966 !      include 'COMMON.GEO'
2967 !      include 'COMMON.VAR'
2968 !      include 'COMMON.LOCAL'
2969 !      include 'COMMON.CHAIN'
2970 !      include 'COMMON.DERIV'
2971 !      include 'COMMON.INTERACT'
2972 !      include 'COMMON.CONTACTS'
2973 !      include 'COMMON.TORSION'
2974 !      include 'COMMON.VECTORS'
2975 !      include 'COMMON.FFIELD'
2976 !      include 'COMMON.TIME1'
2977       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2978       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2979       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2980 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2981       real(kind=8),dimension(4) :: muij
2982 !el      integer :: num_conti,j1,j2
2983 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2984 !el        dz_normi,xmedi,ymedi,zmedi
2985
2986 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2987 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2988 !el          num_conti,j1,j2
2989
2990 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2991 #ifdef MOMENT
2992       real(kind=8) :: scal_el=1.0d0
2993 #else
2994       real(kind=8) :: scal_el=0.5d0
2995 #endif
2996 ! 12/13/98
2997 ! 13-go grudnia roku pamietnego...
2998       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2999                                              0.0d0,1.0d0,0.0d0,&
3000                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3001 !el local variables
3002       integer :: i,k,j
3003       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3004       real(kind=8) :: fac,t_eelecij,fracinbuf
3005
3006
3007 !d      write(iout,*) 'In EELEC'
3008 !        print *,"IN EELEC"
3009 !d      do i=1,nloctyp
3010 !d        write(iout,*) 'Type',i
3011 !d        write(iout,*) 'B1',B1(:,i)
3012 !d        write(iout,*) 'B2',B2(:,i)
3013 !d        write(iout,*) 'CC',CC(:,:,i)
3014 !d        write(iout,*) 'DD',DD(:,:,i)
3015 !d        write(iout,*) 'EE',EE(:,:,i)
3016 !d      enddo
3017 !d      call check_vecgrad
3018 !d      stop
3019 !      ees=0.0d0  !AS
3020 !      evdw1=0.0d0
3021 !      eel_loc=0.0d0
3022 !      eello_turn3=0.0d0
3023 !      eello_turn4=0.0d0
3024       t_eelecij=0.0d0
3025       ees=0.0D0
3026       evdw1=0.0D0
3027       eel_loc=0.0d0
3028       eello_turn3=0.0d0
3029       eello_turn4=0.0d0
3030 !
3031
3032       if (icheckgrad.eq.1) then
3033 !el
3034 !        do i=0,2*nres+2
3035 !          dc_norm(1,i)=0.0d0
3036 !          dc_norm(2,i)=0.0d0
3037 !          dc_norm(3,i)=0.0d0
3038 !        enddo
3039         do i=1,nres-1
3040           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3041           do k=1,3
3042             dc_norm(k,i)=dc(k,i)*fac
3043           enddo
3044 !          write (iout,*) 'i',i,' fac',fac
3045         enddo
3046       endif
3047 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3048 !        wturn6
3049       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3050           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3051           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3052 !        call vec_and_deriv
3053 #ifdef TIMING
3054         time01=MPI_Wtime()
3055 #endif
3056 !        print *, "before set matrices"
3057         call set_matrices
3058 !        print *, "after set matrices"
3059
3060 #ifdef TIMING
3061         time_mat=time_mat+MPI_Wtime()-time01
3062 #endif
3063       endif
3064 !       print *, "after set matrices"
3065 !d      do i=1,nres-1
3066 !d        write (iout,*) 'i=',i
3067 !d        do k=1,3
3068 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3069 !d        enddo
3070 !d        do k=1,3
3071 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3072 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3073 !d        enddo
3074 !d      enddo
3075       t_eelecij=0.0d0
3076       ees=0.0D0
3077       evdw1=0.0D0
3078       eel_loc=0.0d0
3079       eello_turn3=0.0d0
3080       eello_turn4=0.0d0
3081 !el      ind=0
3082       do i=1,nres
3083         num_cont_hb(i)=0
3084       enddo
3085 !d      print '(a)','Enter EELEC'
3086 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3087 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3088 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3089       do i=1,nres
3090         gel_loc_loc(i)=0.0d0
3091         gcorr_loc(i)=0.0d0
3092       enddo
3093 !
3094 !
3095 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3096 !
3097 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3098 !
3099
3100
3101 !        print *,"before iturn3 loop"
3102       do i=iturn3_start,iturn3_end
3103         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3104         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3105         dxi=dc(1,i)
3106         dyi=dc(2,i)
3107         dzi=dc(3,i)
3108         dx_normi=dc_norm(1,i)
3109         dy_normi=dc_norm(2,i)
3110         dz_normi=dc_norm(3,i)
3111         xmedi=c(1,i)+0.5d0*dxi
3112         ymedi=c(2,i)+0.5d0*dyi
3113         zmedi=c(3,i)+0.5d0*dzi
3114           xmedi=dmod(xmedi,boxxsize)
3115           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3116           ymedi=dmod(ymedi,boxysize)
3117           if (ymedi.lt.0) ymedi=ymedi+boxysize
3118           zmedi=dmod(zmedi,boxzsize)
3119           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3120         num_conti=0
3121        if ((zmedi.gt.bordlipbot) &
3122         .and.(zmedi.lt.bordliptop)) then
3123 !C the energy transfer exist
3124         if (zmedi.lt.buflipbot) then
3125 !C what fraction I am in
3126          fracinbuf=1.0d0- &
3127                ((zmedi-bordlipbot)/lipbufthick)
3128 !C lipbufthick is thickenes of lipid buffore
3129          sslipi=sscalelip(fracinbuf)
3130          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3131         elseif (zmedi.gt.bufliptop) then
3132          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3133          sslipi=sscalelip(fracinbuf)
3134          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3135         else
3136          sslipi=1.0d0
3137          ssgradlipi=0.0
3138         endif
3139        else
3140          sslipi=0.0d0
3141          ssgradlipi=0.0
3142        endif
3143 !       print *,i,sslipi,ssgradlipi
3144        call eelecij(i,i+2,ees,evdw1,eel_loc)
3145         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3146         num_cont_hb(i)=num_conti
3147       enddo
3148       do i=iturn4_start,iturn4_end
3149         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3150           .or. itype(i+3,1).eq.ntyp1 &
3151           .or. itype(i+4,1).eq.ntyp1) cycle
3152         dxi=dc(1,i)
3153         dyi=dc(2,i)
3154         dzi=dc(3,i)
3155         dx_normi=dc_norm(1,i)
3156         dy_normi=dc_norm(2,i)
3157         dz_normi=dc_norm(3,i)
3158         xmedi=c(1,i)+0.5d0*dxi
3159         ymedi=c(2,i)+0.5d0*dyi
3160         zmedi=c(3,i)+0.5d0*dzi
3161           xmedi=dmod(xmedi,boxxsize)
3162           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3163           ymedi=dmod(ymedi,boxysize)
3164           if (ymedi.lt.0) ymedi=ymedi+boxysize
3165           zmedi=dmod(zmedi,boxzsize)
3166           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3167        if ((zmedi.gt.bordlipbot)  &
3168        .and.(zmedi.lt.bordliptop)) then
3169 !C the energy transfer exist
3170         if (zmedi.lt.buflipbot) then
3171 !C what fraction I am in
3172          fracinbuf=1.0d0- &
3173              ((zmedi-bordlipbot)/lipbufthick)
3174 !C lipbufthick is thickenes of lipid buffore
3175          sslipi=sscalelip(fracinbuf)
3176          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3177         elseif (zmedi.gt.bufliptop) then
3178          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3179          sslipi=sscalelip(fracinbuf)
3180          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3181         else
3182          sslipi=1.0d0
3183          ssgradlipi=0.0
3184         endif
3185        else
3186          sslipi=0.0d0
3187          ssgradlipi=0.0
3188        endif
3189
3190         num_conti=num_cont_hb(i)
3191         call eelecij(i,i+3,ees,evdw1,eel_loc)
3192         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3193          call eturn4(i,eello_turn4)
3194         num_cont_hb(i)=num_conti
3195       enddo   ! i
3196 !
3197 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3198 !
3199 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3200       do i=iatel_s,iatel_e
3201         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3202         dxi=dc(1,i)
3203         dyi=dc(2,i)
3204         dzi=dc(3,i)
3205         dx_normi=dc_norm(1,i)
3206         dy_normi=dc_norm(2,i)
3207         dz_normi=dc_norm(3,i)
3208         xmedi=c(1,i)+0.5d0*dxi
3209         ymedi=c(2,i)+0.5d0*dyi
3210         zmedi=c(3,i)+0.5d0*dzi
3211           xmedi=dmod(xmedi,boxxsize)
3212           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3213           ymedi=dmod(ymedi,boxysize)
3214           if (ymedi.lt.0) ymedi=ymedi+boxysize
3215           zmedi=dmod(zmedi,boxzsize)
3216           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3217        if ((zmedi.gt.bordlipbot)  &
3218         .and.(zmedi.lt.bordliptop)) then
3219 !C the energy transfer exist
3220         if (zmedi.lt.buflipbot) then
3221 !C what fraction I am in
3222          fracinbuf=1.0d0- &
3223              ((zmedi-bordlipbot)/lipbufthick)
3224 !C lipbufthick is thickenes of lipid buffore
3225          sslipi=sscalelip(fracinbuf)
3226          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3227         elseif (zmedi.gt.bufliptop) then
3228          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3229          sslipi=sscalelip(fracinbuf)
3230          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3231         else
3232          sslipi=1.0d0
3233          ssgradlipi=0.0
3234         endif
3235        else
3236          sslipi=0.0d0
3237          ssgradlipi=0.0
3238        endif
3239
3240 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3241         num_conti=num_cont_hb(i)
3242         do j=ielstart(i),ielend(i)
3243 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3244           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3245           call eelecij(i,j,ees,evdw1,eel_loc)
3246         enddo ! j
3247         num_cont_hb(i)=num_conti
3248       enddo   ! i
3249 !      write (iout,*) "Number of loop steps in EELEC:",ind
3250 !d      do i=1,nres
3251 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3252 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3253 !d      enddo
3254 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3255 !cc      eel_loc=eel_loc+eello_turn3
3256 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3257       return
3258       end subroutine eelec
3259 !-----------------------------------------------------------------------------
3260       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3261
3262       use comm_locel
3263 !      implicit real*8 (a-h,o-z)
3264 !      include 'DIMENSIONS'
3265 #ifdef MPI
3266       include "mpif.h"
3267 #endif
3268 !      include 'COMMON.CONTROL'
3269 !      include 'COMMON.IOUNITS'
3270 !      include 'COMMON.GEO'
3271 !      include 'COMMON.VAR'
3272 !      include 'COMMON.LOCAL'
3273 !      include 'COMMON.CHAIN'
3274 !      include 'COMMON.DERIV'
3275 !      include 'COMMON.INTERACT'
3276 !      include 'COMMON.CONTACTS'
3277 !      include 'COMMON.TORSION'
3278 !      include 'COMMON.VECTORS'
3279 !      include 'COMMON.FFIELD'
3280 !      include 'COMMON.TIME1'
3281       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3282       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3283       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3284 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3285       real(kind=8),dimension(4) :: muij
3286       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3287                     dist_temp, dist_init,rlocshield,fracinbuf
3288       integer xshift,yshift,zshift,ilist,iresshield
3289 !el      integer :: num_conti,j1,j2
3290 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3291 !el        dz_normi,xmedi,ymedi,zmedi
3292
3293 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3294 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3295 !el          num_conti,j1,j2
3296
3297 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3298 #ifdef MOMENT
3299       real(kind=8) :: scal_el=1.0d0
3300 #else
3301       real(kind=8) :: scal_el=0.5d0
3302 #endif
3303 ! 12/13/98
3304 ! 13-go grudnia roku pamietnego...
3305       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3306                                              0.0d0,1.0d0,0.0d0,&
3307                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3308 !      integer :: maxconts=nres/4
3309 !el local variables
3310       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3311       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3312       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3313       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3314                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3315                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3316                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3317                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3318                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3319                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3320                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3321 !      maxconts=nres/4
3322 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3323 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3324
3325 !          time00=MPI_Wtime()
3326 !d      write (iout,*) "eelecij",i,j
3327 !          ind=ind+1
3328           iteli=itel(i)
3329           itelj=itel(j)
3330           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3331           aaa=app(iteli,itelj)
3332           bbb=bpp(iteli,itelj)
3333           ael6i=ael6(iteli,itelj)
3334           ael3i=ael3(iteli,itelj)
3335           dxj=dc(1,j)
3336           dyj=dc(2,j)
3337           dzj=dc(3,j)
3338           dx_normj=dc_norm(1,j)
3339           dy_normj=dc_norm(2,j)
3340           dz_normj=dc_norm(3,j)
3341 !          xj=c(1,j)+0.5D0*dxj-xmedi
3342 !          yj=c(2,j)+0.5D0*dyj-ymedi
3343 !          zj=c(3,j)+0.5D0*dzj-zmedi
3344           xj=c(1,j)+0.5D0*dxj
3345           yj=c(2,j)+0.5D0*dyj
3346           zj=c(3,j)+0.5D0*dzj
3347           xj=mod(xj,boxxsize)
3348           if (xj.lt.0) xj=xj+boxxsize
3349           yj=mod(yj,boxysize)
3350           if (yj.lt.0) yj=yj+boxysize
3351           zj=mod(zj,boxzsize)
3352           if (zj.lt.0) zj=zj+boxzsize
3353        if ((zj.gt.bordlipbot)  &
3354        .and.(zj.lt.bordliptop)) then
3355 !C the energy transfer exist
3356         if (zj.lt.buflipbot) then
3357 !C what fraction I am in
3358          fracinbuf=1.0d0-     &
3359              ((zj-bordlipbot)/lipbufthick)
3360 !C lipbufthick is thickenes of lipid buffore
3361          sslipj=sscalelip(fracinbuf)
3362          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3363         elseif (zj.gt.bufliptop) then
3364          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3365          sslipj=sscalelip(fracinbuf)
3366          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3367         else
3368          sslipj=1.0d0
3369          ssgradlipj=0.0
3370         endif
3371        else
3372          sslipj=0.0d0
3373          ssgradlipj=0.0
3374        endif
3375
3376       isubchap=0
3377       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3378       xj_safe=xj
3379       yj_safe=yj
3380       zj_safe=zj
3381       do xshift=-1,1
3382       do yshift=-1,1
3383       do zshift=-1,1
3384           xj=xj_safe+xshift*boxxsize
3385           yj=yj_safe+yshift*boxysize
3386           zj=zj_safe+zshift*boxzsize
3387           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3388           if(dist_temp.lt.dist_init) then
3389             dist_init=dist_temp
3390             xj_temp=xj
3391             yj_temp=yj
3392             zj_temp=zj
3393             isubchap=1
3394           endif
3395        enddo
3396        enddo
3397        enddo
3398        if (isubchap.eq.1) then
3399 !C          print *,i,j
3400           xj=xj_temp-xmedi
3401           yj=yj_temp-ymedi
3402           zj=zj_temp-zmedi
3403        else
3404           xj=xj_safe-xmedi
3405           yj=yj_safe-ymedi
3406           zj=zj_safe-zmedi
3407        endif
3408
3409           rij=xj*xj+yj*yj+zj*zj
3410           rrmij=1.0D0/rij
3411           rij=dsqrt(rij)
3412 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3413             sss_ele_cut=sscale_ele(rij)
3414             sss_ele_grad=sscagrad_ele(rij)
3415 !             sss_ele_cut=1.0d0
3416 !             sss_ele_grad=0.0d0
3417 !            print *,sss_ele_cut,sss_ele_grad,&
3418 !            (rij),r_cut_ele,rlamb_ele
3419 !            if (sss_ele_cut.le.0.0) go to 128
3420
3421           rmij=1.0D0/rij
3422           r3ij=rrmij*rmij
3423           r6ij=r3ij*r3ij
3424           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3425           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3426           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3427           fac=cosa-3.0D0*cosb*cosg
3428           ev1=aaa*r6ij*r6ij
3429 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3430           if (j.eq.i+2) ev1=scal_el*ev1
3431           ev2=bbb*r6ij
3432           fac3=ael6i*r6ij
3433           fac4=ael3i*r3ij
3434           evdwij=ev1+ev2
3435           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3436           el2=fac4*fac
3437 !          eesij=el1+el2
3438           if (shield_mode.gt.0) then
3439 !C          fac_shield(i)=0.4
3440 !C          fac_shield(j)=0.6
3441           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3442           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3443           eesij=(el1+el2)
3444           ees=ees+eesij*sss_ele_cut
3445 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3446 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3447           else
3448           fac_shield(i)=1.0
3449           fac_shield(j)=1.0
3450           eesij=(el1+el2)
3451           ees=ees+eesij   &
3452             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3453 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3454           endif
3455
3456 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3457           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3458 !          ees=ees+eesij*sss_ele_cut
3459           evdw1=evdw1+evdwij*sss_ele_cut  &
3460            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3461 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3462 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3463 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3464 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3465
3466           if (energy_dec) then
3467 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3468 !                  'evdw1',i,j,evdwij,&
3469 !                  iteli,itelj,aaa,evdw1
3470               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3471               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3472           endif
3473 !
3474 ! Calculate contributions to the Cartesian gradient.
3475 !
3476 #ifdef SPLITELE
3477           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3478               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3479           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3480              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3481           fac1=fac
3482           erij(1)=xj*rmij
3483           erij(2)=yj*rmij
3484           erij(3)=zj*rmij
3485 !
3486 ! Radial derivatives. First process both termini of the fragment (i,j)
3487 !
3488           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3489           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3490           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3491            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3492           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3493             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3494
3495           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3496           (shield_mode.gt.0)) then
3497 !C          print *,i,j
3498           do ilist=1,ishield_list(i)
3499            iresshield=shield_list(ilist,i)
3500            do k=1,3
3501            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3502            *2.0*sss_ele_cut
3503            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3504                    rlocshield &
3505             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3506             *sss_ele_cut
3507             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3508            enddo
3509           enddo
3510           do ilist=1,ishield_list(j)
3511            iresshield=shield_list(ilist,j)
3512            do k=1,3
3513            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3514           *2.0*sss_ele_cut
3515            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3516                    rlocshield &
3517            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3518            *sss_ele_cut
3519            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3520            enddo
3521           enddo
3522           do k=1,3
3523             gshieldc(k,i)=gshieldc(k,i)+ &
3524                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3525            *sss_ele_cut
3526
3527             gshieldc(k,j)=gshieldc(k,j)+ &
3528                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3529            *sss_ele_cut
3530
3531             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3532                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3533            *sss_ele_cut
3534
3535             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3536                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3537            *sss_ele_cut
3538
3539            enddo
3540            endif
3541
3542
3543 !          do k=1,3
3544 !            ghalf=0.5D0*ggg(k)
3545 !            gelc(k,i)=gelc(k,i)+ghalf
3546 !            gelc(k,j)=gelc(k,j)+ghalf
3547 !          enddo
3548 ! 9/28/08 AL Gradient compotents will be summed only at the end
3549           do k=1,3
3550             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3551             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3552           enddo
3553             gelc_long(3,j)=gelc_long(3,j)+  &
3554           ssgradlipj*eesij/2.0d0*lipscale**2&
3555            *sss_ele_cut
3556
3557             gelc_long(3,i)=gelc_long(3,i)+  &
3558           ssgradlipi*eesij/2.0d0*lipscale**2&
3559            *sss_ele_cut
3560
3561
3562 !
3563 ! Loop over residues i+1 thru j-1.
3564 !
3565 !grad          do k=i+1,j-1
3566 !grad            do l=1,3
3567 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3568 !grad            enddo
3569 !grad          enddo
3570           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3571            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3572           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3573            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3574           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3575            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3576
3577 !          do k=1,3
3578 !            ghalf=0.5D0*ggg(k)
3579 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3580 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3581 !          enddo
3582 ! 9/28/08 AL Gradient compotents will be summed only at the end
3583           do k=1,3
3584             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3585             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3586           enddo
3587
3588 !C Lipidic part for scaling weight
3589            gvdwpp(3,j)=gvdwpp(3,j)+ &
3590           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3591            gvdwpp(3,i)=gvdwpp(3,i)+ &
3592           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3593 !! Loop over residues i+1 thru j-1.
3594 !
3595 !grad          do k=i+1,j-1
3596 !grad            do l=1,3
3597 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3598 !grad            enddo
3599 !grad          enddo
3600 #else
3601           facvdw=(ev1+evdwij)*sss_ele_cut &
3602            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3603
3604           facel=(el1+eesij)*sss_ele_cut
3605           fac1=fac
3606           fac=-3*rrmij*(facvdw+facvdw+facel)
3607           erij(1)=xj*rmij
3608           erij(2)=yj*rmij
3609           erij(3)=zj*rmij
3610 !
3611 ! Radial derivatives. First process both termini of the fragment (i,j)
3612 !
3613           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3614           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3615           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3616 !          do k=1,3
3617 !            ghalf=0.5D0*ggg(k)
3618 !            gelc(k,i)=gelc(k,i)+ghalf
3619 !            gelc(k,j)=gelc(k,j)+ghalf
3620 !          enddo
3621 ! 9/28/08 AL Gradient compotents will be summed only at the end
3622           do k=1,3
3623             gelc_long(k,j)=gelc(k,j)+ggg(k)
3624             gelc_long(k,i)=gelc(k,i)-ggg(k)
3625           enddo
3626 !
3627 ! Loop over residues i+1 thru j-1.
3628 !
3629 !grad          do k=i+1,j-1
3630 !grad            do l=1,3
3631 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3632 !grad            enddo
3633 !grad          enddo
3634 ! 9/28/08 AL Gradient compotents will be summed only at the end
3635           ggg(1)=facvdw*xj &
3636            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3637           ggg(2)=facvdw*yj &
3638            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3639           ggg(3)=facvdw*zj &
3640            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3641
3642           do k=1,3
3643             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3644             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3645           enddo
3646            gvdwpp(3,j)=gvdwpp(3,j)+ &
3647           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3648            gvdwpp(3,i)=gvdwpp(3,i)+ &
3649           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3650
3651 #endif
3652 !
3653 ! Angular part
3654 !
3655           ecosa=2.0D0*fac3*fac1+fac4
3656           fac4=-3.0D0*fac4
3657           fac3=-6.0D0*fac3
3658           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3659           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3660           do k=1,3
3661             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3662             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3663           enddo
3664 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3665 !d   &          (dcosg(k),k=1,3)
3666           do k=1,3
3667             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3668              *fac_shield(i)**2*fac_shield(j)**2 &
3669              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3670
3671           enddo
3672 !          do k=1,3
3673 !            ghalf=0.5D0*ggg(k)
3674 !            gelc(k,i)=gelc(k,i)+ghalf
3675 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3676 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3677 !            gelc(k,j)=gelc(k,j)+ghalf
3678 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3679 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3680 !          enddo
3681 !grad          do k=i+1,j-1
3682 !grad            do l=1,3
3683 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3684 !grad            enddo
3685 !grad          enddo
3686           do k=1,3
3687             gelc(k,i)=gelc(k,i) &
3688                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3689                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3690                      *sss_ele_cut &
3691                      *fac_shield(i)**2*fac_shield(j)**2 &
3692                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3693
3694             gelc(k,j)=gelc(k,j) &
3695                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3696                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3697                      *sss_ele_cut  &
3698                      *fac_shield(i)**2*fac_shield(j)**2  &
3699                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3700
3701             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3702             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3703           enddo
3704
3705           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3706               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3707               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3708 !
3709 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3710 !   energy of a peptide unit is assumed in the form of a second-order
3711 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3712 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3713 !   are computed for EVERY pair of non-contiguous peptide groups.
3714 !
3715           if (j.lt.nres-1) then
3716             j1=j+1
3717             j2=j-1
3718           else
3719             j1=j-1
3720             j2=j-2
3721           endif
3722           kkk=0
3723           do k=1,2
3724             do l=1,2
3725               kkk=kkk+1
3726               muij(kkk)=mu(k,i)*mu(l,j)
3727             enddo
3728           enddo
3729 !d         write (iout,*) 'EELEC: i',i,' j',j
3730 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3731 !d          write(iout,*) 'muij',muij
3732           ury=scalar(uy(1,i),erij)
3733           urz=scalar(uz(1,i),erij)
3734           vry=scalar(uy(1,j),erij)
3735           vrz=scalar(uz(1,j),erij)
3736           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3737           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3738           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3739           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3740           fac=dsqrt(-ael6i)*r3ij
3741           a22=a22*fac
3742           a23=a23*fac
3743           a32=a32*fac
3744           a33=a33*fac
3745 !d          write (iout,'(4i5,4f10.5)')
3746 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3747 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3748 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3749 !d     &      uy(:,j),uz(:,j)
3750 !d          write (iout,'(4f10.5)')
3751 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3752 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3753 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3754 !d           write (iout,'(9f10.5/)')
3755 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3756 ! Derivatives of the elements of A in virtual-bond vectors
3757           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3758           do k=1,3
3759             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3760             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3761             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3762             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3763             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3764             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3765             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3766             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3767             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3768             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3769             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3770             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3771           enddo
3772 ! Compute radial contributions to the gradient
3773           facr=-3.0d0*rrmij
3774           a22der=a22*facr
3775           a23der=a23*facr
3776           a32der=a32*facr
3777           a33der=a33*facr
3778           agg(1,1)=a22der*xj
3779           agg(2,1)=a22der*yj
3780           agg(3,1)=a22der*zj
3781           agg(1,2)=a23der*xj
3782           agg(2,2)=a23der*yj
3783           agg(3,2)=a23der*zj
3784           agg(1,3)=a32der*xj
3785           agg(2,3)=a32der*yj
3786           agg(3,3)=a32der*zj
3787           agg(1,4)=a33der*xj
3788           agg(2,4)=a33der*yj
3789           agg(3,4)=a33der*zj
3790 ! Add the contributions coming from er
3791           fac3=-3.0d0*fac
3792           do k=1,3
3793             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3794             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3795             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3796             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3797           enddo
3798           do k=1,3
3799 ! Derivatives in DC(i)
3800 !grad            ghalf1=0.5d0*agg(k,1)
3801 !grad            ghalf2=0.5d0*agg(k,2)
3802 !grad            ghalf3=0.5d0*agg(k,3)
3803 !grad            ghalf4=0.5d0*agg(k,4)
3804             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3805             -3.0d0*uryg(k,2)*vry)!+ghalf1
3806             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3807             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3808             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3809             -3.0d0*urzg(k,2)*vry)!+ghalf3
3810             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3811             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3812 ! Derivatives in DC(i+1)
3813             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3814             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3815             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3816             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3817             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3818             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3819             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3820             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3821 ! Derivatives in DC(j)
3822             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3823             -3.0d0*vryg(k,2)*ury)!+ghalf1
3824             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3825             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3826             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3827             -3.0d0*vryg(k,2)*urz)!+ghalf3
3828             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3829             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3830 ! Derivatives in DC(j+1) or DC(nres-1)
3831             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3832             -3.0d0*vryg(k,3)*ury)
3833             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3834             -3.0d0*vrzg(k,3)*ury)
3835             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3836             -3.0d0*vryg(k,3)*urz)
3837             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3838             -3.0d0*vrzg(k,3)*urz)
3839 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3840 !grad              do l=1,4
3841 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3842 !grad              enddo
3843 !grad            endif
3844           enddo
3845           acipa(1,1)=a22
3846           acipa(1,2)=a23
3847           acipa(2,1)=a32
3848           acipa(2,2)=a33
3849           a22=-a22
3850           a23=-a23
3851           do l=1,2
3852             do k=1,3
3853               agg(k,l)=-agg(k,l)
3854               aggi(k,l)=-aggi(k,l)
3855               aggi1(k,l)=-aggi1(k,l)
3856               aggj(k,l)=-aggj(k,l)
3857               aggj1(k,l)=-aggj1(k,l)
3858             enddo
3859           enddo
3860           if (j.lt.nres-1) then
3861             a22=-a22
3862             a32=-a32
3863             do l=1,3,2
3864               do k=1,3
3865                 agg(k,l)=-agg(k,l)
3866                 aggi(k,l)=-aggi(k,l)
3867                 aggi1(k,l)=-aggi1(k,l)
3868                 aggj(k,l)=-aggj(k,l)
3869                 aggj1(k,l)=-aggj1(k,l)
3870               enddo
3871             enddo
3872           else
3873             a22=-a22
3874             a23=-a23
3875             a32=-a32
3876             a33=-a33
3877             do l=1,4
3878               do k=1,3
3879                 agg(k,l)=-agg(k,l)
3880                 aggi(k,l)=-aggi(k,l)
3881                 aggi1(k,l)=-aggi1(k,l)
3882                 aggj(k,l)=-aggj(k,l)
3883                 aggj1(k,l)=-aggj1(k,l)
3884               enddo
3885             enddo
3886           endif
3887           ENDIF ! WCORR
3888           IF (wel_loc.gt.0.0d0) THEN
3889 ! Contribution to the local-electrostatic energy coming from the i-j pair
3890           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3891            +a33*muij(4)
3892           if (shield_mode.eq.0) then
3893            fac_shield(i)=1.0
3894            fac_shield(j)=1.0
3895           endif
3896           eel_loc_ij=eel_loc_ij &
3897          *fac_shield(i)*fac_shield(j) &
3898          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3899 !C Now derivative over eel_loc
3900           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3901          (shield_mode.gt.0)) then
3902 !C          print *,i,j
3903
3904           do ilist=1,ishield_list(i)
3905            iresshield=shield_list(ilist,i)
3906            do k=1,3
3907            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3908                                                 /fac_shield(i)&
3909            *sss_ele_cut
3910            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3911                    rlocshield  &
3912           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3913           *sss_ele_cut
3914
3915             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3916            +rlocshield
3917            enddo
3918           enddo
3919           do ilist=1,ishield_list(j)
3920            iresshield=shield_list(ilist,j)
3921            do k=1,3
3922            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3923                                             /fac_shield(j)   &
3924             *sss_ele_cut
3925            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3926                    rlocshield  &
3927       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3928        *sss_ele_cut
3929
3930            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3931                   +rlocshield
3932
3933            enddo
3934           enddo
3935
3936           do k=1,3
3937             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3938                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3939                     *sss_ele_cut
3940             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3941                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3942                     *sss_ele_cut
3943             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3944                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3945                     *sss_ele_cut
3946             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3947                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3948                     *sss_ele_cut
3949
3950            enddo
3951            endif
3952
3953
3954 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3955 !           eel_loc_ij=0.0
3956           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3957                   'eelloc',i,j,eel_loc_ij
3958 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3959 !          if (energy_dec) write (iout,*) "muij",muij
3960 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3961
3962           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3963 ! Partial derivatives in virtual-bond dihedral angles gamma
3964           if (i.gt.1) &
3965           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3966                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3967                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3968                  *sss_ele_cut  &
3969           *fac_shield(i)*fac_shield(j) &
3970           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3971
3972           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3973                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3974                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3975                  *sss_ele_cut &
3976           *fac_shield(i)*fac_shield(j) &
3977           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3978 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3979 !          do l=1,3
3980 !            ggg(1)=(agg(1,1)*muij(1)+ &
3981 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3982 !            *sss_ele_cut &
3983 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3984 !            ggg(2)=(agg(2,1)*muij(1)+ &
3985 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3986 !            *sss_ele_cut &
3987 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3988 !            ggg(3)=(agg(3,1)*muij(1)+ &
3989 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3990 !            *sss_ele_cut &
3991 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3992            xtemp(1)=xj
3993            xtemp(2)=yj
3994            xtemp(3)=zj
3995
3996            do l=1,3
3997             ggg(l)=(agg(l,1)*muij(1)+ &
3998                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3999             *sss_ele_cut &
4000           *fac_shield(i)*fac_shield(j) &
4001           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4002              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4003
4004
4005             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4006             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4007 !grad            ghalf=0.5d0*ggg(l)
4008 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4009 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4010           enddo
4011             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4012           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4013           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4014
4015             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4016           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4017           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4018
4019 !grad          do k=i+1,j2
4020 !grad            do l=1,3
4021 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4022 !grad            enddo
4023 !grad          enddo
4024 ! Remaining derivatives of eello
4025           do l=1,3
4026             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4027                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4028             *sss_ele_cut &
4029           *fac_shield(i)*fac_shield(j) &
4030           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4031
4032 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4033             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4034                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4035             +aggi1(l,4)*muij(4))&
4036             *sss_ele_cut &
4037           *fac_shield(i)*fac_shield(j) &
4038           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4039
4040 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4041             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4042                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4043             *sss_ele_cut &
4044           *fac_shield(i)*fac_shield(j) &
4045           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4046
4047 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4048             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4049                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4050             +aggj1(l,4)*muij(4))&
4051             *sss_ele_cut &
4052           *fac_shield(i)*fac_shield(j) &
4053           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4054
4055 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4056           enddo
4057           ENDIF
4058 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4059 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4060           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4061              .and. num_conti.le.maxconts) then
4062 !            write (iout,*) i,j," entered corr"
4063 !
4064 ! Calculate the contact function. The ith column of the array JCONT will
4065 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4066 ! greater than I). The arrays FACONT and GACONT will contain the values of
4067 ! the contact function and its derivative.
4068 !           r0ij=1.02D0*rpp(iteli,itelj)
4069 !           r0ij=1.11D0*rpp(iteli,itelj)
4070             r0ij=2.20D0*rpp(iteli,itelj)
4071 !           r0ij=1.55D0*rpp(iteli,itelj)
4072             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4073 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4074             if (fcont.gt.0.0D0) then
4075               num_conti=num_conti+1
4076               if (num_conti.gt.maxconts) then
4077 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4078 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4079                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4080                                ' will skip next contacts for this conf.', num_conti
4081               else
4082                 jcont_hb(num_conti,i)=j
4083 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4084 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4085                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4086                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4087 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4088 !  terms.
4089                 d_cont(num_conti,i)=rij
4090 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4091 !     --- Electrostatic-interaction matrix ---
4092                 a_chuj(1,1,num_conti,i)=a22
4093                 a_chuj(1,2,num_conti,i)=a23
4094                 a_chuj(2,1,num_conti,i)=a32
4095                 a_chuj(2,2,num_conti,i)=a33
4096 !     --- Gradient of rij
4097                 do kkk=1,3
4098                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4099                 enddo
4100                 kkll=0
4101                 do k=1,2
4102                   do l=1,2
4103                     kkll=kkll+1
4104                     do m=1,3
4105                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4106                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4107                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4108                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4109                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4110                     enddo
4111                   enddo
4112                 enddo
4113                 ENDIF
4114                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4115 ! Calculate contact energies
4116                 cosa4=4.0D0*cosa
4117                 wij=cosa-3.0D0*cosb*cosg
4118                 cosbg1=cosb+cosg
4119                 cosbg2=cosb-cosg
4120 !               fac3=dsqrt(-ael6i)/r0ij**3
4121                 fac3=dsqrt(-ael6i)*r3ij
4122 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4123                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4124                 if (ees0tmp.gt.0) then
4125                   ees0pij=dsqrt(ees0tmp)
4126                 else
4127                   ees0pij=0
4128                 endif
4129                 if (shield_mode.eq.0) then
4130                 fac_shield(i)=1.0d0
4131                 fac_shield(j)=1.0d0
4132                 else
4133                 ees0plist(num_conti,i)=j
4134                 endif
4135 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4136                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4137                 if (ees0tmp.gt.0) then
4138                   ees0mij=dsqrt(ees0tmp)
4139                 else
4140                   ees0mij=0
4141                 endif
4142 !               ees0mij=0.0D0
4143                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4144                      *sss_ele_cut &
4145                      *fac_shield(i)*fac_shield(j)
4146
4147                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4148                      *sss_ele_cut &
4149                      *fac_shield(i)*fac_shield(j)
4150
4151 ! Diagnostics. Comment out or remove after debugging!
4152 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4153 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4154 !               ees0m(num_conti,i)=0.0D0
4155 ! End diagnostics.
4156 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4157 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4158 ! Angular derivatives of the contact function
4159                 ees0pij1=fac3/ees0pij
4160                 ees0mij1=fac3/ees0mij
4161                 fac3p=-3.0D0*fac3*rrmij
4162                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4163                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4164 !               ees0mij1=0.0D0
4165                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4166                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4167                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4168                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4169                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4170                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4171                 ecosap=ecosa1+ecosa2
4172                 ecosbp=ecosb1+ecosb2
4173                 ecosgp=ecosg1+ecosg2
4174                 ecosam=ecosa1-ecosa2
4175                 ecosbm=ecosb1-ecosb2
4176                 ecosgm=ecosg1-ecosg2
4177 ! Diagnostics
4178 !               ecosap=ecosa1
4179 !               ecosbp=ecosb1
4180 !               ecosgp=ecosg1
4181 !               ecosam=0.0D0
4182 !               ecosbm=0.0D0
4183 !               ecosgm=0.0D0
4184 ! End diagnostics
4185                 facont_hb(num_conti,i)=fcont
4186                 fprimcont=fprimcont/rij
4187 !d              facont_hb(num_conti,i)=1.0D0
4188 ! Following line is for diagnostics.
4189 !d              fprimcont=0.0D0
4190                 do k=1,3
4191                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4192                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4193                 enddo
4194                 do k=1,3
4195                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4196                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4197                 enddo
4198                 gggp(1)=gggp(1)+ees0pijp*xj &
4199                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4200                 gggp(2)=gggp(2)+ees0pijp*yj &
4201                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4202                 gggp(3)=gggp(3)+ees0pijp*zj &
4203                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4204
4205                 gggm(1)=gggm(1)+ees0mijp*xj &
4206                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4207
4208                 gggm(2)=gggm(2)+ees0mijp*yj &
4209                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4210
4211                 gggm(3)=gggm(3)+ees0mijp*zj &
4212                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4213
4214 ! Derivatives due to the contact function
4215                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4216                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4217                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4218                 do k=1,3
4219 !
4220 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4221 !          following the change of gradient-summation algorithm.
4222 !
4223 !grad                  ghalfp=0.5D0*gggp(k)
4224 !grad                  ghalfm=0.5D0*gggm(k)
4225                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4226                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4227                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4228                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4229
4230                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4231                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4232                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4233                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4234
4235                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4236                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4237
4238                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4239                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4240                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4241                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4242
4243                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4244                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4245                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4246                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4247
4248                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4249                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4250
4251                 enddo
4252 ! Diagnostics. Comment out or remove after debugging!
4253 !diag           do k=1,3
4254 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4255 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4256 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4257 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4258 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4259 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4260 !diag           enddo
4261               ENDIF ! wcorr
4262               endif  ! num_conti.le.maxconts
4263             endif  ! fcont.gt.0
4264           endif    ! j.gt.i+1
4265           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4266             do k=1,4
4267               do l=1,3
4268                 ghalf=0.5d0*agg(l,k)
4269                 aggi(l,k)=aggi(l,k)+ghalf
4270                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4271                 aggj(l,k)=aggj(l,k)+ghalf
4272               enddo
4273             enddo
4274             if (j.eq.nres-1 .and. i.lt.j-2) then
4275               do k=1,4
4276                 do l=1,3
4277                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4278                 enddo
4279               enddo
4280             endif
4281           endif
4282  128  continue
4283 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4284       return
4285       end subroutine eelecij
4286 !-----------------------------------------------------------------------------
4287       subroutine eturn3(i,eello_turn3)
4288 ! Third- and fourth-order contributions from turns
4289
4290       use comm_locel
4291 !      implicit real*8 (a-h,o-z)
4292 !      include 'DIMENSIONS'
4293 !      include 'COMMON.IOUNITS'
4294 !      include 'COMMON.GEO'
4295 !      include 'COMMON.VAR'
4296 !      include 'COMMON.LOCAL'
4297 !      include 'COMMON.CHAIN'
4298 !      include 'COMMON.DERIV'
4299 !      include 'COMMON.INTERACT'
4300 !      include 'COMMON.CONTACTS'
4301 !      include 'COMMON.TORSION'
4302 !      include 'COMMON.VECTORS'
4303 !      include 'COMMON.FFIELD'
4304 !      include 'COMMON.CONTROL'
4305       real(kind=8),dimension(3) :: ggg
4306       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4307         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4308       real(kind=8),dimension(2) :: auxvec,auxvec1
4309 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4310       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4311 !el      integer :: num_conti,j1,j2
4312 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4313 !el        dz_normi,xmedi,ymedi,zmedi
4314
4315 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4316 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4317 !el         num_conti,j1,j2
4318 !el local variables
4319       integer :: i,j,l,k,ilist,iresshield
4320       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4321
4322       j=i+2
4323 !      write (iout,*) "eturn3",i,j,j1,j2
4324           zj=(c(3,j)+c(3,j+1))/2.0d0
4325           zj=mod(zj,boxzsize)
4326           if (zj.lt.0) zj=zj+boxzsize
4327           if ((zj.lt.0)) write (*,*) "CHUJ"
4328        if ((zj.gt.bordlipbot)  &
4329         .and.(zj.lt.bordliptop)) then
4330 !C the energy transfer exist
4331         if (zj.lt.buflipbot) then
4332 !C what fraction I am in
4333          fracinbuf=1.0d0-     &
4334              ((zj-bordlipbot)/lipbufthick)
4335 !C lipbufthick is thickenes of lipid buffore
4336          sslipj=sscalelip(fracinbuf)
4337          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4338         elseif (zj.gt.bufliptop) then
4339          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4340          sslipj=sscalelip(fracinbuf)
4341          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4342         else
4343          sslipj=1.0d0
4344          ssgradlipj=0.0
4345         endif
4346        else
4347          sslipj=0.0d0
4348          ssgradlipj=0.0
4349        endif
4350
4351       a_temp(1,1)=a22
4352       a_temp(1,2)=a23
4353       a_temp(2,1)=a32
4354       a_temp(2,2)=a33
4355 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4356 !
4357 !               Third-order contributions
4358 !
4359 !                 (i+2)o----(i+3)
4360 !                      | |
4361 !                      | |
4362 !                 (i+1)o----i
4363 !
4364 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4365 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4366         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4367         call transpose2(auxmat(1,1),auxmat1(1,1))
4368         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4369         if (shield_mode.eq.0) then
4370         fac_shield(i)=1.0d0
4371         fac_shield(j)=1.0d0
4372         endif
4373
4374         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4375          *fac_shield(i)*fac_shield(j)  &
4376          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4377         eello_t3= &
4378         0.5d0*(pizda(1,1)+pizda(2,2)) &
4379         *fac_shield(i)*fac_shield(j)
4380
4381         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4382                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4383           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4384        (shield_mode.gt.0)) then
4385 !C          print *,i,j
4386
4387           do ilist=1,ishield_list(i)
4388            iresshield=shield_list(ilist,i)
4389            do k=1,3
4390            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4391            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4392                    rlocshield &
4393            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4394             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4395              +rlocshield
4396            enddo
4397           enddo
4398           do ilist=1,ishield_list(j)
4399            iresshield=shield_list(ilist,j)
4400            do k=1,3
4401            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4402            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4403                    rlocshield &
4404            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4405            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4406                   +rlocshield
4407
4408            enddo
4409           enddo
4410
4411           do k=1,3
4412             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4413                    grad_shield(k,i)*eello_t3/fac_shield(i)
4414             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4415                    grad_shield(k,j)*eello_t3/fac_shield(j)
4416             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4417                    grad_shield(k,i)*eello_t3/fac_shield(i)
4418             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4419                    grad_shield(k,j)*eello_t3/fac_shield(j)
4420            enddo
4421            endif
4422
4423 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4424 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4425 !d     &    ' eello_turn3_num',4*eello_turn3_num
4426 ! Derivatives in gamma(i)
4427         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4428         call transpose2(auxmat2(1,1),auxmat3(1,1))
4429         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4430         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4431           *fac_shield(i)*fac_shield(j)        &
4432           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4433 ! Derivatives in gamma(i+1)
4434         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4435         call transpose2(auxmat2(1,1),auxmat3(1,1))
4436         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4437         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4438           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4439           *fac_shield(i)*fac_shield(j)        &
4440           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4441
4442 ! Cartesian derivatives
4443         do l=1,3
4444 !            ghalf1=0.5d0*agg(l,1)
4445 !            ghalf2=0.5d0*agg(l,2)
4446 !            ghalf3=0.5d0*agg(l,3)
4447 !            ghalf4=0.5d0*agg(l,4)
4448           a_temp(1,1)=aggi(l,1)!+ghalf1
4449           a_temp(1,2)=aggi(l,2)!+ghalf2
4450           a_temp(2,1)=aggi(l,3)!+ghalf3
4451           a_temp(2,2)=aggi(l,4)!+ghalf4
4452           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4453           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4454             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4455           *fac_shield(i)*fac_shield(j)      &
4456           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4457
4458           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4459           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4460           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4461           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4462           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4463           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4464             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4465           *fac_shield(i)*fac_shield(j)        &
4466           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4467
4468           a_temp(1,1)=aggj(l,1)!+ghalf1
4469           a_temp(1,2)=aggj(l,2)!+ghalf2
4470           a_temp(2,1)=aggj(l,3)!+ghalf3
4471           a_temp(2,2)=aggj(l,4)!+ghalf4
4472           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4473           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4474             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4475           *fac_shield(i)*fac_shield(j)      &
4476           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4477
4478           a_temp(1,1)=aggj1(l,1)
4479           a_temp(1,2)=aggj1(l,2)
4480           a_temp(2,1)=aggj1(l,3)
4481           a_temp(2,2)=aggj1(l,4)
4482           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4483           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4484             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4485           *fac_shield(i)*fac_shield(j)        &
4486           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4487         enddo
4488          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4489           ssgradlipi*eello_t3/4.0d0*lipscale
4490          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4491           ssgradlipj*eello_t3/4.0d0*lipscale
4492          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4493           ssgradlipi*eello_t3/4.0d0*lipscale
4494          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4495           ssgradlipj*eello_t3/4.0d0*lipscale
4496
4497       return
4498       end subroutine eturn3
4499 !-----------------------------------------------------------------------------
4500       subroutine eturn4(i,eello_turn4)
4501 ! Third- and fourth-order contributions from turns
4502
4503       use comm_locel
4504 !      implicit real*8 (a-h,o-z)
4505 !      include 'DIMENSIONS'
4506 !      include 'COMMON.IOUNITS'
4507 !      include 'COMMON.GEO'
4508 !      include 'COMMON.VAR'
4509 !      include 'COMMON.LOCAL'
4510 !      include 'COMMON.CHAIN'
4511 !      include 'COMMON.DERIV'
4512 !      include 'COMMON.INTERACT'
4513 !      include 'COMMON.CONTACTS'
4514 !      include 'COMMON.TORSION'
4515 !      include 'COMMON.VECTORS'
4516 !      include 'COMMON.FFIELD'
4517 !      include 'COMMON.CONTROL'
4518       real(kind=8),dimension(3) :: ggg
4519       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4520         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4521       real(kind=8),dimension(2) :: auxvec,auxvec1
4522 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4523       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4524 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4525 !el        dz_normi,xmedi,ymedi,zmedi
4526 !el      integer :: num_conti,j1,j2
4527 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4528 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4529 !el          num_conti,j1,j2
4530 !el local variables
4531       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4532       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4533          rlocshield
4534
4535       j=i+3
4536 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4537 !
4538 !               Fourth-order contributions
4539 !
4540 !                 (i+3)o----(i+4)
4541 !                     /  |
4542 !               (i+2)o   |
4543 !                     \  |
4544 !                 (i+1)o----i
4545 !
4546 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4547 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4548 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4549           zj=(c(3,j)+c(3,j+1))/2.0d0
4550           zj=mod(zj,boxzsize)
4551           if (zj.lt.0) zj=zj+boxzsize
4552        if ((zj.gt.bordlipbot)  &
4553         .and.(zj.lt.bordliptop)) then
4554 !C the energy transfer exist
4555         if (zj.lt.buflipbot) then
4556 !C what fraction I am in
4557          fracinbuf=1.0d0-     &
4558              ((zj-bordlipbot)/lipbufthick)
4559 !C lipbufthick is thickenes of lipid buffore
4560          sslipj=sscalelip(fracinbuf)
4561          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4562         elseif (zj.gt.bufliptop) then
4563          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4564          sslipj=sscalelip(fracinbuf)
4565          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4566         else
4567          sslipj=1.0d0
4568          ssgradlipj=0.0
4569         endif
4570        else
4571          sslipj=0.0d0
4572          ssgradlipj=0.0
4573        endif
4574
4575         a_temp(1,1)=a22
4576         a_temp(1,2)=a23
4577         a_temp(2,1)=a32
4578         a_temp(2,2)=a33
4579         iti1=itortyp(itype(i+1,1))
4580         iti2=itortyp(itype(i+2,1))
4581         iti3=itortyp(itype(i+3,1))
4582 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4583         call transpose2(EUg(1,1,i+1),e1t(1,1))
4584         call transpose2(Eug(1,1,i+2),e2t(1,1))
4585         call transpose2(Eug(1,1,i+3),e3t(1,1))
4586         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4587         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4588         s1=scalar2(b1(1,iti2),auxvec(1))
4589         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4590         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4591         s2=scalar2(b1(1,iti1),auxvec(1))
4592         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4593         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4594         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4595         if (shield_mode.eq.0) then
4596         fac_shield(i)=1.0
4597         fac_shield(j)=1.0
4598         endif
4599
4600         eello_turn4=eello_turn4-(s1+s2+s3) &
4601         *fac_shield(i)*fac_shield(j)       &
4602         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4603         eello_t4=-(s1+s2+s3)  &
4604           *fac_shield(i)*fac_shield(j)
4605 !C Now derivative over shield:
4606           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4607          (shield_mode.gt.0)) then
4608 !C          print *,i,j
4609
4610           do ilist=1,ishield_list(i)
4611            iresshield=shield_list(ilist,i)
4612            do k=1,3
4613            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4614            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4615                    rlocshield &
4616             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4617             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4618            +rlocshield
4619            enddo
4620           enddo
4621           do ilist=1,ishield_list(j)
4622            iresshield=shield_list(ilist,j)
4623            do k=1,3
4624            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4625            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4626                    rlocshield  &
4627            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4628            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4629                   +rlocshield
4630
4631            enddo
4632           enddo
4633
4634           do k=1,3
4635             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4636                    grad_shield(k,i)*eello_t4/fac_shield(i)
4637             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4638                    grad_shield(k,j)*eello_t4/fac_shield(j)
4639             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4640                    grad_shield(k,i)*eello_t4/fac_shield(i)
4641             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4642                    grad_shield(k,j)*eello_t4/fac_shield(j)
4643            enddo
4644            endif
4645
4646         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4647            'eturn4',i,j,-(s1+s2+s3)
4648 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4649 !d     &    ' eello_turn4_num',8*eello_turn4_num
4650 ! Derivatives in gamma(i)
4651         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4652         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4653         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4654         s1=scalar2(b1(1,iti2),auxvec(1))
4655         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4656         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4657         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4658        *fac_shield(i)*fac_shield(j)  &
4659        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4660
4661 ! Derivatives in gamma(i+1)
4662         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4663         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4664         s2=scalar2(b1(1,iti1),auxvec(1))
4665         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4666         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4667         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4668         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4669        *fac_shield(i)*fac_shield(j)  &
4670        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4671
4672 ! Derivatives in gamma(i+2)
4673         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4674         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4675         s1=scalar2(b1(1,iti2),auxvec(1))
4676         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4677         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4678         s2=scalar2(b1(1,iti1),auxvec(1))
4679         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4680         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4681         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4682         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4683        *fac_shield(i)*fac_shield(j)  &
4684        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4685
4686 ! Cartesian derivatives
4687 ! Derivatives of this turn contributions in DC(i+2)
4688         if (j.lt.nres-1) then
4689           do l=1,3
4690             a_temp(1,1)=agg(l,1)
4691             a_temp(1,2)=agg(l,2)
4692             a_temp(2,1)=agg(l,3)
4693             a_temp(2,2)=agg(l,4)
4694             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4695             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4696             s1=scalar2(b1(1,iti2),auxvec(1))
4697             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4698             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4699             s2=scalar2(b1(1,iti1),auxvec(1))
4700             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4701             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4702             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4703             ggg(l)=-(s1+s2+s3)
4704             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4705        *fac_shield(i)*fac_shield(j)  &
4706        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4707
4708           enddo
4709         endif
4710 ! Remaining derivatives of this turn contribution
4711         do l=1,3
4712           a_temp(1,1)=aggi(l,1)
4713           a_temp(1,2)=aggi(l,2)
4714           a_temp(2,1)=aggi(l,3)
4715           a_temp(2,2)=aggi(l,4)
4716           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4717           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4718           s1=scalar2(b1(1,iti2),auxvec(1))
4719           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4720           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4721           s2=scalar2(b1(1,iti1),auxvec(1))
4722           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4723           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4724           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4725           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4726          *fac_shield(i)*fac_shield(j)  &
4727          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4728
4729
4730           a_temp(1,1)=aggi1(l,1)
4731           a_temp(1,2)=aggi1(l,2)
4732           a_temp(2,1)=aggi1(l,3)
4733           a_temp(2,2)=aggi1(l,4)
4734           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4735           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4736           s1=scalar2(b1(1,iti2),auxvec(1))
4737           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4738           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4739           s2=scalar2(b1(1,iti1),auxvec(1))
4740           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4741           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4742           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4743           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4744          *fac_shield(i)*fac_shield(j)  &
4745          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4746
4747
4748           a_temp(1,1)=aggj(l,1)
4749           a_temp(1,2)=aggj(l,2)
4750           a_temp(2,1)=aggj(l,3)
4751           a_temp(2,2)=aggj(l,4)
4752           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4753           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4754           s1=scalar2(b1(1,iti2),auxvec(1))
4755           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4756           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4757           s2=scalar2(b1(1,iti1),auxvec(1))
4758           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4759           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4760           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4761           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4762          *fac_shield(i)*fac_shield(j)  &
4763          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4764
4765
4766           a_temp(1,1)=aggj1(l,1)
4767           a_temp(1,2)=aggj1(l,2)
4768           a_temp(2,1)=aggj1(l,3)
4769           a_temp(2,2)=aggj1(l,4)
4770           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4771           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4772           s1=scalar2(b1(1,iti2),auxvec(1))
4773           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4774           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4775           s2=scalar2(b1(1,iti1),auxvec(1))
4776           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4777           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4778           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4779 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4780           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4781          *fac_shield(i)*fac_shield(j)  &
4782          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4783
4784         enddo
4785          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4786           ssgradlipi*eello_t4/4.0d0*lipscale
4787          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4788           ssgradlipj*eello_t4/4.0d0*lipscale
4789          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4790           ssgradlipi*eello_t4/4.0d0*lipscale
4791          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4792           ssgradlipj*eello_t4/4.0d0*lipscale
4793
4794       return
4795       end subroutine eturn4
4796 !-----------------------------------------------------------------------------
4797       subroutine unormderiv(u,ugrad,unorm,ungrad)
4798 ! This subroutine computes the derivatives of a normalized vector u, given
4799 ! the derivatives computed without normalization conditions, ugrad. Returns
4800 ! ungrad.
4801 !      implicit none
4802       real(kind=8),dimension(3) :: u,vec
4803       real(kind=8),dimension(3,3) ::ugrad,ungrad
4804       real(kind=8) :: unorm      !,scalar
4805       integer :: i,j
4806 !      write (2,*) 'ugrad',ugrad
4807 !      write (2,*) 'u',u
4808       do i=1,3
4809         vec(i)=scalar(ugrad(1,i),u(1))
4810       enddo
4811 !      write (2,*) 'vec',vec
4812       do i=1,3
4813         do j=1,3
4814           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4815         enddo
4816       enddo
4817 !      write (2,*) 'ungrad',ungrad
4818       return
4819       end subroutine unormderiv
4820 !-----------------------------------------------------------------------------
4821       subroutine escp_soft_sphere(evdw2,evdw2_14)
4822 !
4823 ! This subroutine calculates the excluded-volume interaction energy between
4824 ! peptide-group centers and side chains and its gradient in virtual-bond and
4825 ! side-chain vectors.
4826 !
4827 !      implicit real*8 (a-h,o-z)
4828 !      include 'DIMENSIONS'
4829 !      include 'COMMON.GEO'
4830 !      include 'COMMON.VAR'
4831 !      include 'COMMON.LOCAL'
4832 !      include 'COMMON.CHAIN'
4833 !      include 'COMMON.DERIV'
4834 !      include 'COMMON.INTERACT'
4835 !      include 'COMMON.FFIELD'
4836 !      include 'COMMON.IOUNITS'
4837 !      include 'COMMON.CONTROL'
4838       real(kind=8),dimension(3) :: ggg
4839 !el local variables
4840       integer :: i,iint,j,k,iteli,itypj
4841       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4842                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4843
4844       evdw2=0.0D0
4845       evdw2_14=0.0d0
4846       r0_scp=4.5d0
4847 !d    print '(a)','Enter ESCP'
4848 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4849       do i=iatscp_s,iatscp_e
4850         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4851         iteli=itel(i)
4852         xi=0.5D0*(c(1,i)+c(1,i+1))
4853         yi=0.5D0*(c(2,i)+c(2,i+1))
4854         zi=0.5D0*(c(3,i)+c(3,i+1))
4855
4856         do iint=1,nscp_gr(i)
4857
4858         do j=iscpstart(i,iint),iscpend(i,iint)
4859           if (itype(j,1).eq.ntyp1) cycle
4860           itypj=iabs(itype(j,1))
4861 ! Uncomment following three lines for SC-p interactions
4862 !         xj=c(1,nres+j)-xi
4863 !         yj=c(2,nres+j)-yi
4864 !         zj=c(3,nres+j)-zi
4865 ! Uncomment following three lines for Ca-p interactions
4866           xj=c(1,j)-xi
4867           yj=c(2,j)-yi
4868           zj=c(3,j)-zi
4869           rij=xj*xj+yj*yj+zj*zj
4870           r0ij=r0_scp
4871           r0ijsq=r0ij*r0ij
4872           if (rij.lt.r0ijsq) then
4873             evdwij=0.25d0*(rij-r0ijsq)**2
4874             fac=rij-r0ijsq
4875           else
4876             evdwij=0.0d0
4877             fac=0.0d0
4878           endif
4879           evdw2=evdw2+evdwij
4880 !
4881 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4882 !
4883           ggg(1)=xj*fac
4884           ggg(2)=yj*fac
4885           ggg(3)=zj*fac
4886 !grad          if (j.lt.i) then
4887 !d          write (iout,*) 'j<i'
4888 ! Uncomment following three lines for SC-p interactions
4889 !           do k=1,3
4890 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4891 !           enddo
4892 !grad          else
4893 !d          write (iout,*) 'j>i'
4894 !grad            do k=1,3
4895 !grad              ggg(k)=-ggg(k)
4896 ! Uncomment following line for SC-p interactions
4897 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4898 !grad            enddo
4899 !grad          endif
4900 !grad          do k=1,3
4901 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4902 !grad          enddo
4903 !grad          kstart=min0(i+1,j)
4904 !grad          kend=max0(i-1,j-1)
4905 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4906 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4907 !grad          do k=kstart,kend
4908 !grad            do l=1,3
4909 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4910 !grad            enddo
4911 !grad          enddo
4912           do k=1,3
4913             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4914             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4915           enddo
4916         enddo
4917
4918         enddo ! iint
4919       enddo ! i
4920       return
4921       end subroutine escp_soft_sphere
4922 !-----------------------------------------------------------------------------
4923       subroutine escp(evdw2,evdw2_14)
4924 !
4925 ! This subroutine calculates the excluded-volume interaction energy between
4926 ! peptide-group centers and side chains and its gradient in virtual-bond and
4927 ! side-chain vectors.
4928 !
4929 !      implicit real*8 (a-h,o-z)
4930 !      include 'DIMENSIONS'
4931 !      include 'COMMON.GEO'
4932 !      include 'COMMON.VAR'
4933 !      include 'COMMON.LOCAL'
4934 !      include 'COMMON.CHAIN'
4935 !      include 'COMMON.DERIV'
4936 !      include 'COMMON.INTERACT'
4937 !      include 'COMMON.FFIELD'
4938 !      include 'COMMON.IOUNITS'
4939 !      include 'COMMON.CONTROL'
4940       real(kind=8),dimension(3) :: ggg
4941 !el local variables
4942       integer :: i,iint,j,k,iteli,itypj,subchap
4943       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4944                    e1,e2,evdwij,rij
4945       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4946                     dist_temp, dist_init
4947       integer xshift,yshift,zshift
4948
4949       evdw2=0.0D0
4950       evdw2_14=0.0d0
4951 !d    print '(a)','Enter ESCP'
4952 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4953       do i=iatscp_s,iatscp_e
4954         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4955         iteli=itel(i)
4956         xi=0.5D0*(c(1,i)+c(1,i+1))
4957         yi=0.5D0*(c(2,i)+c(2,i+1))
4958         zi=0.5D0*(c(3,i)+c(3,i+1))
4959           xi=mod(xi,boxxsize)
4960           if (xi.lt.0) xi=xi+boxxsize
4961           yi=mod(yi,boxysize)
4962           if (yi.lt.0) yi=yi+boxysize
4963           zi=mod(zi,boxzsize)
4964           if (zi.lt.0) zi=zi+boxzsize
4965
4966         do iint=1,nscp_gr(i)
4967
4968         do j=iscpstart(i,iint),iscpend(i,iint)
4969           itypj=iabs(itype(j,1))
4970           if (itypj.eq.ntyp1) cycle
4971 ! Uncomment following three lines for SC-p interactions
4972 !         xj=c(1,nres+j)-xi
4973 !         yj=c(2,nres+j)-yi
4974 !         zj=c(3,nres+j)-zi
4975 ! Uncomment following three lines for Ca-p interactions
4976 !          xj=c(1,j)-xi
4977 !          yj=c(2,j)-yi
4978 !          zj=c(3,j)-zi
4979           xj=c(1,j)
4980           yj=c(2,j)
4981           zj=c(3,j)
4982           xj=mod(xj,boxxsize)
4983           if (xj.lt.0) xj=xj+boxxsize
4984           yj=mod(yj,boxysize)
4985           if (yj.lt.0) yj=yj+boxysize
4986           zj=mod(zj,boxzsize)
4987           if (zj.lt.0) zj=zj+boxzsize
4988       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4989       xj_safe=xj
4990       yj_safe=yj
4991       zj_safe=zj
4992       subchap=0
4993       do xshift=-1,1
4994       do yshift=-1,1
4995       do zshift=-1,1
4996           xj=xj_safe+xshift*boxxsize
4997           yj=yj_safe+yshift*boxysize
4998           zj=zj_safe+zshift*boxzsize
4999           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5000           if(dist_temp.lt.dist_init) then
5001             dist_init=dist_temp
5002             xj_temp=xj
5003             yj_temp=yj
5004             zj_temp=zj
5005             subchap=1
5006           endif
5007        enddo
5008        enddo
5009        enddo
5010        if (subchap.eq.1) then
5011           xj=xj_temp-xi
5012           yj=yj_temp-yi
5013           zj=zj_temp-zi
5014        else
5015           xj=xj_safe-xi
5016           yj=yj_safe-yi
5017           zj=zj_safe-zi
5018        endif
5019
5020           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5021           rij=dsqrt(1.0d0/rrij)
5022             sss_ele_cut=sscale_ele(rij)
5023             sss_ele_grad=sscagrad_ele(rij)
5024 !            print *,sss_ele_cut,sss_ele_grad,&
5025 !            (rij),r_cut_ele,rlamb_ele
5026             if (sss_ele_cut.le.0.0) cycle
5027           fac=rrij**expon2
5028           e1=fac*fac*aad(itypj,iteli)
5029           e2=fac*bad(itypj,iteli)
5030           if (iabs(j-i) .le. 2) then
5031             e1=scal14*e1
5032             e2=scal14*e2
5033             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5034           endif
5035           evdwij=e1+e2
5036           evdw2=evdw2+evdwij*sss_ele_cut
5037 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5038 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5039           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5040              'evdw2',i,j,evdwij
5041 !
5042 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5043 !
5044           fac=-(evdwij+e1)*rrij*sss_ele_cut
5045           fac=fac+evdwij*sss_ele_grad/rij/expon
5046           ggg(1)=xj*fac
5047           ggg(2)=yj*fac
5048           ggg(3)=zj*fac
5049 !grad          if (j.lt.i) then
5050 !d          write (iout,*) 'j<i'
5051 ! Uncomment following three lines for SC-p interactions
5052 !           do k=1,3
5053 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5054 !           enddo
5055 !grad          else
5056 !d          write (iout,*) 'j>i'
5057 !grad            do k=1,3
5058 !grad              ggg(k)=-ggg(k)
5059 ! Uncomment following line for SC-p interactions
5060 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5061 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5062 !grad            enddo
5063 !grad          endif
5064 !grad          do k=1,3
5065 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5066 !grad          enddo
5067 !grad          kstart=min0(i+1,j)
5068 !grad          kend=max0(i-1,j-1)
5069 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5070 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5071 !grad          do k=kstart,kend
5072 !grad            do l=1,3
5073 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5074 !grad            enddo
5075 !grad          enddo
5076           do k=1,3
5077             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5078             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5079           enddo
5080         enddo
5081
5082         enddo ! iint
5083       enddo ! i
5084       do i=1,nct
5085         do j=1,3
5086           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5087           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5088           gradx_scp(j,i)=expon*gradx_scp(j,i)
5089         enddo
5090       enddo
5091 !******************************************************************************
5092 !
5093 !                              N O T E !!!
5094 !
5095 ! To save time the factor EXPON has been extracted from ALL components
5096 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5097 ! use!
5098 !
5099 !******************************************************************************
5100       return
5101       end subroutine escp
5102 !-----------------------------------------------------------------------------
5103       subroutine edis(ehpb)
5104 !
5105 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5106 !
5107 !      implicit real*8 (a-h,o-z)
5108 !      include 'DIMENSIONS'
5109 !      include 'COMMON.SBRIDGE'
5110 !      include 'COMMON.CHAIN'
5111 !      include 'COMMON.DERIV'
5112 !      include 'COMMON.VAR'
5113 !      include 'COMMON.INTERACT'
5114 !      include 'COMMON.IOUNITS'
5115       real(kind=8),dimension(3) :: ggg
5116 !el local variables
5117       integer :: i,j,ii,jj,iii,jjj,k
5118       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5119
5120       ehpb=0.0D0
5121 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5122 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5123       if (link_end.eq.0) return
5124       do i=link_start,link_end
5125 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5126 ! CA-CA distance used in regularization of structure.
5127         ii=ihpb(i)
5128         jj=jhpb(i)
5129 ! iii and jjj point to the residues for which the distance is assigned.
5130         if (ii.gt.nres) then
5131           iii=ii-nres
5132           jjj=jj-nres
5133         else
5134           iii=ii
5135           jjj=jj
5136         endif
5137 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5138 !     &    dhpb(i),dhpb1(i),forcon(i)
5139 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5140 !    distance and angle dependent SS bond potential.
5141 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5142 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5143         if (.not.dyn_ss .and. i.le.nss) then
5144 ! 15/02/13 CC dynamic SSbond - additional check
5145          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5146         iabs(itype(jjj,1)).eq.1) then
5147           call ssbond_ene(iii,jjj,eij)
5148           ehpb=ehpb+2*eij
5149 !d          write (iout,*) "eij",eij
5150          endif
5151         else if (ii.gt.nres .and. jj.gt.nres) then
5152 !c Restraints from contact prediction
5153           dd=dist(ii,jj)
5154           if (constr_dist.eq.11) then
5155             ehpb=ehpb+fordepth(i)**4.0d0 &
5156                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5157             fac=fordepth(i)**4.0d0 &
5158                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5159           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5160             ehpb,fordepth(i),dd
5161            else
5162           if (dhpb1(i).gt.0.0d0) then
5163             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5164             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5165 !c            write (iout,*) "beta nmr",
5166 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5167           else
5168             dd=dist(ii,jj)
5169             rdis=dd-dhpb(i)
5170 !C Get the force constant corresponding to this distance.
5171             waga=forcon(i)
5172 !C Calculate the contribution to energy.
5173             ehpb=ehpb+waga*rdis*rdis
5174 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5175 !C
5176 !C Evaluate gradient.
5177 !C
5178             fac=waga*rdis/dd
5179           endif
5180           endif
5181           do j=1,3
5182             ggg(j)=fac*(c(j,jj)-c(j,ii))
5183           enddo
5184           do j=1,3
5185             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5186             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5187           enddo
5188           do k=1,3
5189             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5190             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5191           enddo
5192         else
5193           dd=dist(ii,jj)
5194           if (constr_dist.eq.11) then
5195             ehpb=ehpb+fordepth(i)**4.0d0 &
5196                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5197             fac=fordepth(i)**4.0d0 &
5198                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5199           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5200          ehpb,fordepth(i),dd
5201            else
5202           if (dhpb1(i).gt.0.0d0) then
5203             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5204             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5205 !c            write (iout,*) "alph nmr",
5206 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5207           else
5208             rdis=dd-dhpb(i)
5209 !C Get the force constant corresponding to this distance.
5210             waga=forcon(i)
5211 !C Calculate the contribution to energy.
5212             ehpb=ehpb+waga*rdis*rdis
5213 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5214 !C
5215 !C Evaluate gradient.
5216 !C
5217             fac=waga*rdis/dd
5218           endif
5219           endif
5220
5221             do j=1,3
5222               ggg(j)=fac*(c(j,jj)-c(j,ii))
5223             enddo
5224 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5225 !C If this is a SC-SC distance, we need to calculate the contributions to the
5226 !C Cartesian gradient in the SC vectors (ghpbx).
5227           if (iii.lt.ii) then
5228           do j=1,3
5229             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5230             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5231           enddo
5232           endif
5233 !cgrad        do j=iii,jjj-1
5234 !cgrad          do k=1,3
5235 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5236 !cgrad          enddo
5237 !cgrad        enddo
5238           do k=1,3
5239             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5240             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5241           enddo
5242         endif
5243       enddo
5244       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5245
5246       return
5247       end subroutine edis
5248 !-----------------------------------------------------------------------------
5249       subroutine ssbond_ene(i,j,eij)
5250 !
5251 ! Calculate the distance and angle dependent SS-bond potential energy
5252 ! using a free-energy function derived based on RHF/6-31G** ab initio
5253 ! calculations of diethyl disulfide.
5254 !
5255 ! A. Liwo and U. Kozlowska, 11/24/03
5256 !
5257 !      implicit real*8 (a-h,o-z)
5258 !      include 'DIMENSIONS'
5259 !      include 'COMMON.SBRIDGE'
5260 !      include 'COMMON.CHAIN'
5261 !      include 'COMMON.DERIV'
5262 !      include 'COMMON.LOCAL'
5263 !      include 'COMMON.INTERACT'
5264 !      include 'COMMON.VAR'
5265 !      include 'COMMON.IOUNITS'
5266       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5267 !el local variables
5268       integer :: i,j,itypi,itypj,k
5269       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5270                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5271                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5272                    cosphi,ggk
5273
5274       itypi=iabs(itype(i,1))
5275       xi=c(1,nres+i)
5276       yi=c(2,nres+i)
5277       zi=c(3,nres+i)
5278       dxi=dc_norm(1,nres+i)
5279       dyi=dc_norm(2,nres+i)
5280       dzi=dc_norm(3,nres+i)
5281 !      dsci_inv=dsc_inv(itypi)
5282       dsci_inv=vbld_inv(nres+i)
5283       itypj=iabs(itype(j,1))
5284 !      dscj_inv=dsc_inv(itypj)
5285       dscj_inv=vbld_inv(nres+j)
5286       xj=c(1,nres+j)-xi
5287       yj=c(2,nres+j)-yi
5288       zj=c(3,nres+j)-zi
5289       dxj=dc_norm(1,nres+j)
5290       dyj=dc_norm(2,nres+j)
5291       dzj=dc_norm(3,nres+j)
5292       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5293       rij=dsqrt(rrij)
5294       erij(1)=xj*rij
5295       erij(2)=yj*rij
5296       erij(3)=zj*rij
5297       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5298       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5299       om12=dxi*dxj+dyi*dyj+dzi*dzj
5300       do k=1,3
5301         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5302         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5303       enddo
5304       rij=1.0d0/rij
5305       deltad=rij-d0cm
5306       deltat1=1.0d0-om1
5307       deltat2=1.0d0+om2
5308       deltat12=om2-om1+2.0d0
5309       cosphi=om12-om1*om2
5310       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5311         +akct*deltad*deltat12 &
5312         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5313 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5314 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5315 !     &  " deltat12",deltat12," eij",eij
5316       ed=2*akcm*deltad+akct*deltat12
5317       pom1=akct*deltad
5318       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5319       eom1=-2*akth*deltat1-pom1-om2*pom2
5320       eom2= 2*akth*deltat2+pom1-om1*pom2
5321       eom12=pom2
5322       do k=1,3
5323         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5324         ghpbx(k,i)=ghpbx(k,i)-ggk &
5325                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5326                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5327         ghpbx(k,j)=ghpbx(k,j)+ggk &
5328                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5329                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5330         ghpbc(k,i)=ghpbc(k,i)-ggk
5331         ghpbc(k,j)=ghpbc(k,j)+ggk
5332       enddo
5333 !
5334 ! Calculate the components of the gradient in DC and X
5335 !
5336 !grad      do k=i,j-1
5337 !grad        do l=1,3
5338 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5339 !grad        enddo
5340 !grad      enddo
5341       return
5342       end subroutine ssbond_ene
5343 !-----------------------------------------------------------------------------
5344       subroutine ebond(estr)
5345 !
5346 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5347 !
5348 !      implicit real*8 (a-h,o-z)
5349 !      include 'DIMENSIONS'
5350 !      include 'COMMON.LOCAL'
5351 !      include 'COMMON.GEO'
5352 !      include 'COMMON.INTERACT'
5353 !      include 'COMMON.DERIV'
5354 !      include 'COMMON.VAR'
5355 !      include 'COMMON.CHAIN'
5356 !      include 'COMMON.IOUNITS'
5357 !      include 'COMMON.NAMES'
5358 !      include 'COMMON.FFIELD'
5359 !      include 'COMMON.CONTROL'
5360 !      include 'COMMON.SETUP'
5361       real(kind=8),dimension(3) :: u,ud
5362 !el local variables
5363       integer :: i,j,iti,nbi,k
5364       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5365                    uprod1,uprod2
5366
5367       estr=0.0d0
5368       estr1=0.0d0
5369 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5370 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5371
5372       do i=ibondp_start,ibondp_end
5373         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5374         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5375 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5376 !C          do j=1,3
5377 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5378 !C            *dc(j,i-1)/vbld(i)
5379 !C          enddo
5380 !C          if (energy_dec) write(iout,*) &
5381 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5382         diff = vbld(i)-vbldpDUM
5383         else
5384         diff = vbld(i)-vbldp0
5385         endif
5386         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5387            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5388         estr=estr+diff*diff
5389         do j=1,3
5390           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5391         enddo
5392 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5393 !        endif
5394       enddo
5395       estr=0.5d0*AKP*estr+estr1
5396 !      print *,"estr_bb",estr,AKP
5397 !
5398 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5399 !
5400       do i=ibond_start,ibond_end
5401         iti=iabs(itype(i,1))
5402         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5403         if (iti.ne.10 .and. iti.ne.ntyp1) then
5404           nbi=nbondterm(iti)
5405           if (nbi.eq.1) then
5406             diff=vbld(i+nres)-vbldsc0(1,iti)
5407             if (energy_dec) write (iout,*) &
5408             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5409             AKSC(1,iti),AKSC(1,iti)*diff*diff
5410             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5411 !            print *,"estr_sc",estr
5412             do j=1,3
5413               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5414             enddo
5415           else
5416             do j=1,nbi
5417               diff=vbld(i+nres)-vbldsc0(j,iti)
5418               ud(j)=aksc(j,iti)*diff
5419               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5420             enddo
5421             uprod=u(1)
5422             do j=2,nbi
5423               uprod=uprod*u(j)
5424             enddo
5425             usum=0.0d0
5426             usumsqder=0.0d0
5427             do j=1,nbi
5428               uprod1=1.0d0
5429               uprod2=1.0d0
5430               do k=1,nbi
5431                 if (k.ne.j) then
5432                   uprod1=uprod1*u(k)
5433                   uprod2=uprod2*u(k)*u(k)
5434                 endif
5435               enddo
5436               usum=usum+uprod1
5437               usumsqder=usumsqder+ud(j)*uprod2
5438             enddo
5439             estr=estr+uprod/usum
5440 !            print *,"estr_sc",estr,i
5441
5442              if (energy_dec) write (iout,*) &
5443             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5444             AKSC(1,iti),uprod/usum
5445             do j=1,3
5446              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5447             enddo
5448           endif
5449         endif
5450       enddo
5451       return
5452       end subroutine ebond
5453 #ifdef CRYST_THETA
5454 !-----------------------------------------------------------------------------
5455       subroutine ebend(etheta)
5456 !
5457 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5458 ! angles gamma and its derivatives in consecutive thetas and gammas.
5459 !
5460       use comm_calcthet
5461 !      implicit real*8 (a-h,o-z)
5462 !      include 'DIMENSIONS'
5463 !      include 'COMMON.LOCAL'
5464 !      include 'COMMON.GEO'
5465 !      include 'COMMON.INTERACT'
5466 !      include 'COMMON.DERIV'
5467 !      include 'COMMON.VAR'
5468 !      include 'COMMON.CHAIN'
5469 !      include 'COMMON.IOUNITS'
5470 !      include 'COMMON.NAMES'
5471 !      include 'COMMON.FFIELD'
5472 !      include 'COMMON.CONTROL'
5473 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5474 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5475 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5476 !el      integer :: it
5477 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5478 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5479 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5480 !el local variables
5481       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5482        ichir21,ichir22
5483       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5484        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5485        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5486       real(kind=8),dimension(2) :: y,z
5487
5488       delta=0.02d0*pi
5489 !      time11=dexp(-2*time)
5490 !      time12=1.0d0
5491       etheta=0.0D0
5492 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5493       do i=ithet_start,ithet_end
5494         if (itype(i-1,1).eq.ntyp1) cycle
5495 ! Zero the energy function and its derivative at 0 or pi.
5496         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5497         it=itype(i-1,1)
5498         ichir1=isign(1,itype(i-2,1))
5499         ichir2=isign(1,itype(i,1))
5500          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5501          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5502          if (itype(i-1,1).eq.10) then
5503           itype1=isign(10,itype(i-2,1))
5504           ichir11=isign(1,itype(i-2,1))
5505           ichir12=isign(1,itype(i-2,1))
5506           itype2=isign(10,itype(i,1))
5507           ichir21=isign(1,itype(i,1))
5508           ichir22=isign(1,itype(i,1))
5509          endif
5510
5511         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5512 #ifdef OSF
5513           phii=phi(i)
5514           if (phii.ne.phii) phii=150.0
5515 #else
5516           phii=phi(i)
5517 #endif
5518           y(1)=dcos(phii)
5519           y(2)=dsin(phii)
5520         else
5521           y(1)=0.0D0
5522           y(2)=0.0D0
5523         endif
5524         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5525 #ifdef OSF
5526           phii1=phi(i+1)
5527           if (phii1.ne.phii1) phii1=150.0
5528           phii1=pinorm(phii1)
5529           z(1)=cos(phii1)
5530 #else
5531           phii1=phi(i+1)
5532           z(1)=dcos(phii1)
5533 #endif
5534           z(2)=dsin(phii1)
5535         else
5536           z(1)=0.0D0
5537           z(2)=0.0D0
5538         endif
5539 ! Calculate the "mean" value of theta from the part of the distribution
5540 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5541 ! In following comments this theta will be referred to as t_c.
5542         thet_pred_mean=0.0d0
5543         do k=1,2
5544             athetk=athet(k,it,ichir1,ichir2)
5545             bthetk=bthet(k,it,ichir1,ichir2)
5546           if (it.eq.10) then
5547              athetk=athet(k,itype1,ichir11,ichir12)
5548              bthetk=bthet(k,itype2,ichir21,ichir22)
5549           endif
5550          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5551         enddo
5552         dthett=thet_pred_mean*ssd
5553         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5554 ! Derivatives of the "mean" values in gamma1 and gamma2.
5555         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5556                +athet(2,it,ichir1,ichir2)*y(1))*ss
5557         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5558                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5559          if (it.eq.10) then
5560         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5561              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5562         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5563                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5564          endif
5565         if (theta(i).gt.pi-delta) then
5566           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5567                E_tc0)
5568           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5569           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5570           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5571               E_theta)
5572           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5573               E_tc)
5574         else if (theta(i).lt.delta) then
5575           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5576           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5577           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5578               E_theta)
5579           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5580           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5581               E_tc)
5582         else
5583           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5584               E_theta,E_tc)
5585         endif
5586         etheta=etheta+ethetai
5587         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5588             'ebend',i,ethetai
5589         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5590         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5591         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5592       enddo
5593 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5594
5595 ! Ufff.... We've done all this!!!
5596       return
5597       end subroutine ebend
5598 !-----------------------------------------------------------------------------
5599       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5600
5601       use comm_calcthet
5602 !      implicit real*8 (a-h,o-z)
5603 !      include 'DIMENSIONS'
5604 !      include 'COMMON.LOCAL'
5605 !      include 'COMMON.IOUNITS'
5606 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5607 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5608 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5609       integer :: i,j,k
5610       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5611 !el      integer :: it
5612 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5613 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5614 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5615 !el local variables
5616       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5617        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5618
5619 ! Calculate the contributions to both Gaussian lobes.
5620 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5621 ! The "polynomial part" of the "standard deviation" of this part of
5622 ! the distribution.
5623         sig=polthet(3,it)
5624         do j=2,0,-1
5625           sig=sig*thet_pred_mean+polthet(j,it)
5626         enddo
5627 ! Derivative of the "interior part" of the "standard deviation of the"
5628 ! gamma-dependent Gaussian lobe in t_c.
5629         sigtc=3*polthet(3,it)
5630         do j=2,1,-1
5631           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5632         enddo
5633         sigtc=sig*sigtc
5634 ! Set the parameters of both Gaussian lobes of the distribution.
5635 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5636         fac=sig*sig+sigc0(it)
5637         sigcsq=fac+fac
5638         sigc=1.0D0/sigcsq
5639 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5640         sigsqtc=-4.0D0*sigcsq*sigtc
5641 !       print *,i,sig,sigtc,sigsqtc
5642 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5643         sigtc=-sigtc/(fac*fac)
5644 ! Following variable is sigma(t_c)**(-2)
5645         sigcsq=sigcsq*sigcsq
5646         sig0i=sig0(it)
5647         sig0inv=1.0D0/sig0i**2
5648         delthec=thetai-thet_pred_mean
5649         delthe0=thetai-theta0i
5650         term1=-0.5D0*sigcsq*delthec*delthec
5651         term2=-0.5D0*sig0inv*delthe0*delthe0
5652 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5653 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5654 ! to the energy (this being the log of the distribution) at the end of energy
5655 ! term evaluation for this virtual-bond angle.
5656         if (term1.gt.term2) then
5657           termm=term1
5658           term2=dexp(term2-termm)
5659           term1=1.0d0
5660         else
5661           termm=term2
5662           term1=dexp(term1-termm)
5663           term2=1.0d0
5664         endif
5665 ! The ratio between the gamma-independent and gamma-dependent lobes of
5666 ! the distribution is a Gaussian function of thet_pred_mean too.
5667         diffak=gthet(2,it)-thet_pred_mean
5668         ratak=diffak/gthet(3,it)**2
5669         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5670 ! Let's differentiate it in thet_pred_mean NOW.
5671         aktc=ak*ratak
5672 ! Now put together the distribution terms to make complete distribution.
5673         termexp=term1+ak*term2
5674         termpre=sigc+ak*sig0i
5675 ! Contribution of the bending energy from this theta is just the -log of
5676 ! the sum of the contributions from the two lobes and the pre-exponential
5677 ! factor. Simple enough, isn't it?
5678         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5679 ! NOW the derivatives!!!
5680 ! 6/6/97 Take into account the deformation.
5681         E_theta=(delthec*sigcsq*term1 &
5682              +ak*delthe0*sig0inv*term2)/termexp
5683         E_tc=((sigtc+aktc*sig0i)/termpre &
5684             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5685              aktc*term2)/termexp)
5686       return
5687       end subroutine theteng
5688 #else
5689 !-----------------------------------------------------------------------------
5690       subroutine ebend(etheta,ethetacnstr)
5691 !
5692 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5693 ! angles gamma and its derivatives in consecutive thetas and gammas.
5694 ! ab initio-derived potentials from
5695 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5696 !
5697 !      implicit real*8 (a-h,o-z)
5698 !      include 'DIMENSIONS'
5699 !      include 'COMMON.LOCAL'
5700 !      include 'COMMON.GEO'
5701 !      include 'COMMON.INTERACT'
5702 !      include 'COMMON.DERIV'
5703 !      include 'COMMON.VAR'
5704 !      include 'COMMON.CHAIN'
5705 !      include 'COMMON.IOUNITS'
5706 !      include 'COMMON.NAMES'
5707 !      include 'COMMON.FFIELD'
5708 !      include 'COMMON.CONTROL'
5709       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5710       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5711       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5712       logical :: lprn=.false., lprn1=.false.
5713 !el local variables
5714       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5715       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5716       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5717 ! local variables for constrains
5718       real(kind=8) :: difi,thetiii
5719        integer itheta
5720
5721       etheta=0.0D0
5722       do i=ithet_start,ithet_end
5723         if (itype(i-1,1).eq.ntyp1) cycle
5724         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5725         if (iabs(itype(i+1,1)).eq.20) iblock=2
5726         if (iabs(itype(i+1,1)).ne.20) iblock=1
5727         dethetai=0.0d0
5728         dephii=0.0d0
5729         dephii1=0.0d0
5730         theti2=0.5d0*theta(i)
5731         ityp2=ithetyp((itype(i-1,1)))
5732         do k=1,nntheterm
5733           coskt(k)=dcos(k*theti2)
5734           sinkt(k)=dsin(k*theti2)
5735         enddo
5736         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5737 #ifdef OSF
5738           phii=phi(i)
5739           if (phii.ne.phii) phii=150.0
5740 #else
5741           phii=phi(i)
5742 #endif
5743           ityp1=ithetyp((itype(i-2,1)))
5744 ! propagation of chirality for glycine type
5745           do k=1,nsingle
5746             cosph1(k)=dcos(k*phii)
5747             sinph1(k)=dsin(k*phii)
5748           enddo
5749         else
5750           phii=0.0d0
5751           ityp1=ithetyp(itype(i-2,1))
5752           do k=1,nsingle
5753             cosph1(k)=0.0d0
5754             sinph1(k)=0.0d0
5755           enddo
5756         endif
5757         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5758 #ifdef OSF
5759           phii1=phi(i+1)
5760           if (phii1.ne.phii1) phii1=150.0
5761           phii1=pinorm(phii1)
5762 #else
5763           phii1=phi(i+1)
5764 #endif
5765           ityp3=ithetyp((itype(i,1)))
5766           do k=1,nsingle
5767             cosph2(k)=dcos(k*phii1)
5768             sinph2(k)=dsin(k*phii1)
5769           enddo
5770         else
5771           phii1=0.0d0
5772           ityp3=ithetyp(itype(i,1))
5773           do k=1,nsingle
5774             cosph2(k)=0.0d0
5775             sinph2(k)=0.0d0
5776           enddo
5777         endif
5778         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5779         do k=1,ndouble
5780           do l=1,k-1
5781             ccl=cosph1(l)*cosph2(k-l)
5782             ssl=sinph1(l)*sinph2(k-l)
5783             scl=sinph1(l)*cosph2(k-l)
5784             csl=cosph1(l)*sinph2(k-l)
5785             cosph1ph2(l,k)=ccl-ssl
5786             cosph1ph2(k,l)=ccl+ssl
5787             sinph1ph2(l,k)=scl+csl
5788             sinph1ph2(k,l)=scl-csl
5789           enddo
5790         enddo
5791         if (lprn) then
5792         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5793           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5794         write (iout,*) "coskt and sinkt"
5795         do k=1,nntheterm
5796           write (iout,*) k,coskt(k),sinkt(k)
5797         enddo
5798         endif
5799         do k=1,ntheterm
5800           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5801           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5802             *coskt(k)
5803           if (lprn) &
5804           write (iout,*) "k",k,&
5805            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5806            " ethetai",ethetai
5807         enddo
5808         if (lprn) then
5809         write (iout,*) "cosph and sinph"
5810         do k=1,nsingle
5811           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5812         enddo
5813         write (iout,*) "cosph1ph2 and sinph2ph2"
5814         do k=2,ndouble
5815           do l=1,k-1
5816             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5817                sinph1ph2(l,k),sinph1ph2(k,l)
5818           enddo
5819         enddo
5820         write(iout,*) "ethetai",ethetai
5821         endif
5822         do m=1,ntheterm2
5823           do k=1,nsingle
5824             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5825                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5826                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5827                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5828             ethetai=ethetai+sinkt(m)*aux
5829             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5830             dephii=dephii+k*sinkt(m)* &
5831                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5832                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5833             dephii1=dephii1+k*sinkt(m)* &
5834                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5835                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5836             if (lprn) &
5837             write (iout,*) "m",m," k",k," bbthet", &
5838                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5839                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5840                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5841                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5842           enddo
5843         enddo
5844         if (lprn) &
5845         write(iout,*) "ethetai",ethetai
5846         do m=1,ntheterm3
5847           do k=2,ndouble
5848             do l=1,k-1
5849               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5850                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5851                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5852                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5853               ethetai=ethetai+sinkt(m)*aux
5854               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5855               dephii=dephii+l*sinkt(m)* &
5856                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5857                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5858                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5859                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5860               dephii1=dephii1+(k-l)*sinkt(m)* &
5861                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5862                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5863                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5864                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5865               if (lprn) then
5866               write (iout,*) "m",m," k",k," l",l," ffthet",&
5867                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5868                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5869                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5870                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5871                   " ethetai",ethetai
5872               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5873                   cosph1ph2(k,l)*sinkt(m),&
5874                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5875               endif
5876             enddo
5877           enddo
5878         enddo
5879 10      continue
5880 !        lprn1=.true.
5881         if (lprn1) &
5882           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5883          i,theta(i)*rad2deg,phii*rad2deg,&
5884          phii1*rad2deg,ethetai
5885 !        lprn1=.false.
5886         etheta=etheta+ethetai
5887         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5888                                     'ebend',i,ethetai
5889         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5890         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5891         gloc(nphi+i-2,icg)=wang*dethetai
5892       enddo
5893 !-----------thete constrains
5894 !      if (tor_mode.ne.2) then
5895       ethetacnstr=0.0d0
5896 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5897       do i=ithetaconstr_start,ithetaconstr_end
5898         itheta=itheta_constr(i)
5899         thetiii=theta(itheta)
5900         difi=pinorm(thetiii-theta_constr0(i))
5901         if (difi.gt.theta_drange(i)) then
5902           difi=difi-theta_drange(i)
5903           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5904           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5905          +for_thet_constr(i)*difi**3
5906         else if (difi.lt.-drange(i)) then
5907           difi=difi+drange(i)
5908           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5909           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5910          +for_thet_constr(i)*difi**3
5911         else
5912           difi=0.0
5913         endif
5914        if (energy_dec) then
5915         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5916          i,itheta,rad2deg*thetiii, &
5917          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5918          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5919          gloc(itheta+nphi-2,icg)
5920         endif
5921       enddo
5922 !      endif
5923
5924       return
5925       end subroutine ebend
5926 #endif
5927 #ifdef CRYST_SC
5928 !-----------------------------------------------------------------------------
5929       subroutine esc(escloc)
5930 ! Calculate the local energy of a side chain and its derivatives in the
5931 ! corresponding virtual-bond valence angles THETA and the spherical angles
5932 ! ALPHA and OMEGA.
5933 !
5934       use comm_sccalc
5935 !      implicit real*8 (a-h,o-z)
5936 !      include 'DIMENSIONS'
5937 !      include 'COMMON.GEO'
5938 !      include 'COMMON.LOCAL'
5939 !      include 'COMMON.VAR'
5940 !      include 'COMMON.INTERACT'
5941 !      include 'COMMON.DERIV'
5942 !      include 'COMMON.CHAIN'
5943 !      include 'COMMON.IOUNITS'
5944 !      include 'COMMON.NAMES'
5945 !      include 'COMMON.FFIELD'
5946 !      include 'COMMON.CONTROL'
5947       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5948          ddersc0,ddummy,xtemp,temp
5949 !el      real(kind=8) :: time11,time12,time112,theti
5950       real(kind=8) :: escloc,delta
5951 !el      integer :: it,nlobit
5952 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5953 !el local variables
5954       integer :: i,k
5955       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5956        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5957       delta=0.02d0*pi
5958       escloc=0.0D0
5959 !     write (iout,'(a)') 'ESC'
5960       do i=loc_start,loc_end
5961         it=itype(i,1)
5962         if (it.eq.ntyp1) cycle
5963         if (it.eq.10) goto 1
5964         nlobit=nlob(iabs(it))
5965 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5966 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5967         theti=theta(i+1)-pipol
5968         x(1)=dtan(theti)
5969         x(2)=alph(i)
5970         x(3)=omeg(i)
5971
5972         if (x(2).gt.pi-delta) then
5973           xtemp(1)=x(1)
5974           xtemp(2)=pi-delta
5975           xtemp(3)=x(3)
5976           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5977           xtemp(2)=pi
5978           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5979           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5980               escloci,dersc(2))
5981           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5982               ddersc0(1),dersc(1))
5983           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5984               ddersc0(3),dersc(3))
5985           xtemp(2)=pi-delta
5986           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5987           xtemp(2)=pi
5988           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5989           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5990                   dersc0(2),esclocbi,dersc02)
5991           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5992                   dersc12,dersc01)
5993           call splinthet(x(2),0.5d0*delta,ss,ssd)
5994           dersc0(1)=dersc01
5995           dersc0(2)=dersc02
5996           dersc0(3)=0.0d0
5997           do k=1,3
5998             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5999           enddo
6000           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6001 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6002 !    &             esclocbi,ss,ssd
6003           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6004 !         escloci=esclocbi
6005 !         write (iout,*) escloci
6006         else if (x(2).lt.delta) then
6007           xtemp(1)=x(1)
6008           xtemp(2)=delta
6009           xtemp(3)=x(3)
6010           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6011           xtemp(2)=0.0d0
6012           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6013           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6014               escloci,dersc(2))
6015           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6016               ddersc0(1),dersc(1))
6017           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6018               ddersc0(3),dersc(3))
6019           xtemp(2)=delta
6020           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6021           xtemp(2)=0.0d0
6022           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6023           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6024                   dersc0(2),esclocbi,dersc02)
6025           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6026                   dersc12,dersc01)
6027           dersc0(1)=dersc01
6028           dersc0(2)=dersc02
6029           dersc0(3)=0.0d0
6030           call splinthet(x(2),0.5d0*delta,ss,ssd)
6031           do k=1,3
6032             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6033           enddo
6034           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6035 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6036 !    &             esclocbi,ss,ssd
6037           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6038 !         write (iout,*) escloci
6039         else
6040           call enesc(x,escloci,dersc,ddummy,.false.)
6041         endif
6042
6043         escloc=escloc+escloci
6044         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6045            'escloc',i,escloci
6046 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6047
6048         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6049          wscloc*dersc(1)
6050         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6051         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6052     1   continue
6053       enddo
6054       return
6055       end subroutine esc
6056 !-----------------------------------------------------------------------------
6057       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6058
6059       use comm_sccalc
6060 !      implicit real*8 (a-h,o-z)
6061 !      include 'DIMENSIONS'
6062 !      include 'COMMON.GEO'
6063 !      include 'COMMON.LOCAL'
6064 !      include 'COMMON.IOUNITS'
6065 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6066       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6067       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6068       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6069       real(kind=8) :: escloci
6070       logical :: mixed
6071 !el local variables
6072       integer :: j,iii,l,k !el,it,nlobit
6073       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6074 !el       time11,time12,time112
6075 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6076         escloc_i=0.0D0
6077         do j=1,3
6078           dersc(j)=0.0D0
6079           if (mixed) ddersc(j)=0.0d0
6080         enddo
6081         x3=x(3)
6082
6083 ! Because of periodicity of the dependence of the SC energy in omega we have
6084 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6085 ! To avoid underflows, first compute & store the exponents.
6086
6087         do iii=-1,1
6088
6089           x(3)=x3+iii*dwapi
6090
6091           do j=1,nlobit
6092             do k=1,3
6093               z(k)=x(k)-censc(k,j,it)
6094             enddo
6095             do k=1,3
6096               Axk=0.0D0
6097               do l=1,3
6098                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6099               enddo
6100               Ax(k,j,iii)=Axk
6101             enddo
6102             expfac=0.0D0
6103             do k=1,3
6104               expfac=expfac+Ax(k,j,iii)*z(k)
6105             enddo
6106             contr(j,iii)=expfac
6107           enddo ! j
6108
6109         enddo ! iii
6110
6111         x(3)=x3
6112 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6113 ! subsequent NaNs and INFs in energy calculation.
6114 ! Find the largest exponent
6115         emin=contr(1,-1)
6116         do iii=-1,1
6117           do j=1,nlobit
6118             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6119           enddo
6120         enddo
6121         emin=0.5D0*emin
6122 !d      print *,'it=',it,' emin=',emin
6123
6124 ! Compute the contribution to SC energy and derivatives
6125         do iii=-1,1
6126
6127           do j=1,nlobit
6128 #ifdef OSF
6129             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6130             if(adexp.ne.adexp) adexp=1.0
6131             expfac=dexp(adexp)
6132 #else
6133             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6134 #endif
6135 !d          print *,'j=',j,' expfac=',expfac
6136             escloc_i=escloc_i+expfac
6137             do k=1,3
6138               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6139             enddo
6140             if (mixed) then
6141               do k=1,3,2
6142                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6143                   +gaussc(k,2,j,it))*expfac
6144               enddo
6145             endif
6146           enddo
6147
6148         enddo ! iii
6149
6150         dersc(1)=dersc(1)/cos(theti)**2
6151         ddersc(1)=ddersc(1)/cos(theti)**2
6152         ddersc(3)=ddersc(3)
6153
6154         escloci=-(dlog(escloc_i)-emin)
6155         do j=1,3
6156           dersc(j)=dersc(j)/escloc_i
6157         enddo
6158         if (mixed) then
6159           do j=1,3,2
6160             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6161           enddo
6162         endif
6163       return
6164       end subroutine enesc
6165 !-----------------------------------------------------------------------------
6166       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6167
6168       use comm_sccalc
6169 !      implicit real*8 (a-h,o-z)
6170 !      include 'DIMENSIONS'
6171 !      include 'COMMON.GEO'
6172 !      include 'COMMON.LOCAL'
6173 !      include 'COMMON.IOUNITS'
6174 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6175       real(kind=8),dimension(3) :: x,z,dersc
6176       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6177       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6178       real(kind=8) :: escloci,dersc12,emin
6179       logical :: mixed
6180 !el local varables
6181       integer :: j,k,l !el,it,nlobit
6182       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6183
6184       escloc_i=0.0D0
6185
6186       do j=1,3
6187         dersc(j)=0.0D0
6188       enddo
6189
6190       do j=1,nlobit
6191         do k=1,2
6192           z(k)=x(k)-censc(k,j,it)
6193         enddo
6194         z(3)=dwapi
6195         do k=1,3
6196           Axk=0.0D0
6197           do l=1,3
6198             Axk=Axk+gaussc(l,k,j,it)*z(l)
6199           enddo
6200           Ax(k,j)=Axk
6201         enddo
6202         expfac=0.0D0
6203         do k=1,3
6204           expfac=expfac+Ax(k,j)*z(k)
6205         enddo
6206         contr(j)=expfac
6207       enddo ! j
6208
6209 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6210 ! subsequent NaNs and INFs in energy calculation.
6211 ! Find the largest exponent
6212       emin=contr(1)
6213       do j=1,nlobit
6214         if (emin.gt.contr(j)) emin=contr(j)
6215       enddo
6216       emin=0.5D0*emin
6217
6218 ! Compute the contribution to SC energy and derivatives
6219
6220       dersc12=0.0d0
6221       do j=1,nlobit
6222         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6223         escloc_i=escloc_i+expfac
6224         do k=1,2
6225           dersc(k)=dersc(k)+Ax(k,j)*expfac
6226         enddo
6227         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6228                   +gaussc(1,2,j,it))*expfac
6229         dersc(3)=0.0d0
6230       enddo
6231
6232       dersc(1)=dersc(1)/cos(theti)**2
6233       dersc12=dersc12/cos(theti)**2
6234       escloci=-(dlog(escloc_i)-emin)
6235       do j=1,2
6236         dersc(j)=dersc(j)/escloc_i
6237       enddo
6238       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6239       return
6240       end subroutine enesc_bound
6241 #else
6242 !-----------------------------------------------------------------------------
6243       subroutine esc(escloc)
6244 ! Calculate the local energy of a side chain and its derivatives in the
6245 ! corresponding virtual-bond valence angles THETA and the spherical angles
6246 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6247 ! added by Urszula Kozlowska. 07/11/2007
6248 !
6249       use comm_sccalc
6250 !      implicit real*8 (a-h,o-z)
6251 !      include 'DIMENSIONS'
6252 !      include 'COMMON.GEO'
6253 !      include 'COMMON.LOCAL'
6254 !      include 'COMMON.VAR'
6255 !      include 'COMMON.SCROT'
6256 !      include 'COMMON.INTERACT'
6257 !      include 'COMMON.DERIV'
6258 !      include 'COMMON.CHAIN'
6259 !      include 'COMMON.IOUNITS'
6260 !      include 'COMMON.NAMES'
6261 !      include 'COMMON.FFIELD'
6262 !      include 'COMMON.CONTROL'
6263 !      include 'COMMON.VECTORS'
6264       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6265       real(kind=8),dimension(65) :: x
6266       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6267          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6268       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6269       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6270          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6271 !el local variables
6272       integer :: i,j,k !el,it,nlobit
6273       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6274 !el      real(kind=8) :: time11,time12,time112,theti
6275 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6276       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6277                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6278                    sumene1x,sumene2x,sumene3x,sumene4x,&
6279                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6280                    cosfac2xx,sinfac2yy
6281 #ifdef DEBUG
6282       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6283                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6284                    de_dt_num
6285 #endif
6286 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6287
6288       delta=0.02d0*pi
6289       escloc=0.0D0
6290       do i=loc_start,loc_end
6291         if (itype(i,1).eq.ntyp1) cycle
6292         costtab(i+1) =dcos(theta(i+1))
6293         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6294         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6295         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6296         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6297         cosfac=dsqrt(cosfac2)
6298         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6299         sinfac=dsqrt(sinfac2)
6300         it=iabs(itype(i,1))
6301         if (it.eq.10) goto 1
6302 !
6303 !  Compute the axes of tghe local cartesian coordinates system; store in
6304 !   x_prime, y_prime and z_prime
6305 !
6306         do j=1,3
6307           x_prime(j) = 0.00
6308           y_prime(j) = 0.00
6309           z_prime(j) = 0.00
6310         enddo
6311 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6312 !     &   dc_norm(3,i+nres)
6313         do j = 1,3
6314           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6315           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6316         enddo
6317         do j = 1,3
6318           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6319         enddo
6320 !       write (2,*) "i",i
6321 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6322 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6323 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6324 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6325 !      & " xy",scalar(x_prime(1),y_prime(1)),
6326 !      & " xz",scalar(x_prime(1),z_prime(1)),
6327 !      & " yy",scalar(y_prime(1),y_prime(1)),
6328 !      & " yz",scalar(y_prime(1),z_prime(1)),
6329 !      & " zz",scalar(z_prime(1),z_prime(1))
6330 !
6331 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6332 ! to local coordinate system. Store in xx, yy, zz.
6333 !
6334         xx=0.0d0
6335         yy=0.0d0
6336         zz=0.0d0
6337         do j = 1,3
6338           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6339           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6340           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6341         enddo
6342
6343         xxtab(i)=xx
6344         yytab(i)=yy
6345         zztab(i)=zz
6346 !
6347 ! Compute the energy of the ith side cbain
6348 !
6349 !        write (2,*) "xx",xx," yy",yy," zz",zz
6350         it=iabs(itype(i,1))
6351         do j = 1,65
6352           x(j) = sc_parmin(j,it)
6353         enddo
6354 #ifdef CHECK_COORD
6355 !c diagnostics - remove later
6356         xx1 = dcos(alph(2))
6357         yy1 = dsin(alph(2))*dcos(omeg(2))
6358         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6359         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6360           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6361           xx1,yy1,zz1
6362 !,"  --- ", xx_w,yy_w,zz_w
6363 ! end diagnostics
6364 #endif
6365         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6366          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6367          + x(10)*yy*zz
6368         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6369          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6370          + x(20)*yy*zz
6371         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6372          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6373          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6374          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6375          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6376          +x(40)*xx*yy*zz
6377         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6378          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6379          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6380          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6381          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6382          +x(60)*xx*yy*zz
6383         dsc_i   = 0.743d0+x(61)
6384         dp2_i   = 1.9d0+x(62)
6385         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6386                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6387         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6388                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6389         s1=(1+x(63))/(0.1d0 + dscp1)
6390         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6391         s2=(1+x(65))/(0.1d0 + dscp2)
6392         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6393         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6394       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6395 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6396 !     &   sumene4,
6397 !     &   dscp1,dscp2,sumene
6398 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6399         escloc = escloc + sumene
6400 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6401 !     & ,zz,xx,yy
6402 !#define DEBUG
6403 #ifdef DEBUG
6404 !
6405 ! This section to check the numerical derivatives of the energy of ith side
6406 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6407 ! #define DEBUG in the code to turn it on.
6408 !
6409         write (2,*) "sumene               =",sumene
6410         aincr=1.0d-7
6411         xxsave=xx
6412         xx=xx+aincr
6413         write (2,*) xx,yy,zz
6414         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6415         de_dxx_num=(sumenep-sumene)/aincr
6416         xx=xxsave
6417         write (2,*) "xx+ sumene from enesc=",sumenep
6418         yysave=yy
6419         yy=yy+aincr
6420         write (2,*) xx,yy,zz
6421         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6422         de_dyy_num=(sumenep-sumene)/aincr
6423         yy=yysave
6424         write (2,*) "yy+ sumene from enesc=",sumenep
6425         zzsave=zz
6426         zz=zz+aincr
6427         write (2,*) xx,yy,zz
6428         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6429         de_dzz_num=(sumenep-sumene)/aincr
6430         zz=zzsave
6431         write (2,*) "zz+ sumene from enesc=",sumenep
6432         costsave=cost2tab(i+1)
6433         sintsave=sint2tab(i+1)
6434         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6435         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6436         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6437         de_dt_num=(sumenep-sumene)/aincr
6438         write (2,*) " t+ sumene from enesc=",sumenep
6439         cost2tab(i+1)=costsave
6440         sint2tab(i+1)=sintsave
6441 ! End of diagnostics section.
6442 #endif
6443 !
6444 ! Compute the gradient of esc
6445 !
6446 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6447         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6448         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6449         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6450         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6451         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6452         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6453         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6454         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6455         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6456            *(pom_s1/dscp1+pom_s16*dscp1**4)
6457         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6458            *(pom_s2/dscp2+pom_s26*dscp2**4)
6459         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6460         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6461         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6462         +x(40)*yy*zz
6463         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6464         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6465         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6466         +x(60)*yy*zz
6467         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6468               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6469               +(pom1+pom2)*pom_dx
6470 #ifdef DEBUG
6471         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6472 #endif
6473 !
6474         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6475         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6476         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6477         +x(40)*xx*zz
6478         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6479         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6480         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6481         +x(59)*zz**2 +x(60)*xx*zz
6482         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6483               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6484               +(pom1-pom2)*pom_dy
6485 #ifdef DEBUG
6486         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6487 #endif
6488 !
6489         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6490         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6491         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6492         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6493         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6494         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6495         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6496         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6497 #ifdef DEBUG
6498         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6499 #endif
6500 !
6501         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6502         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6503         +pom1*pom_dt1+pom2*pom_dt2
6504 #ifdef DEBUG
6505         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6506 #endif
6507 !
6508 !
6509        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6510        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6511        cosfac2xx=cosfac2*xx
6512        sinfac2yy=sinfac2*yy
6513        do k = 1,3
6514          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6515             vbld_inv(i+1)
6516          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6517             vbld_inv(i)
6518          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6519          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6520 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6521 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6522 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6523 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6524          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6525          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6526          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6527          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6528          dZZ_Ci1(k)=0.0d0
6529          dZZ_Ci(k)=0.0d0
6530          do j=1,3
6531            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6532            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6533            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6534            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6535          enddo
6536
6537          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6538          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6539          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6540          (z_prime(k)-zz*dC_norm(k,i+nres))
6541 !
6542          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6543          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6544        enddo
6545
6546        do k=1,3
6547          dXX_Ctab(k,i)=dXX_Ci(k)
6548          dXX_C1tab(k,i)=dXX_Ci1(k)
6549          dYY_Ctab(k,i)=dYY_Ci(k)
6550          dYY_C1tab(k,i)=dYY_Ci1(k)
6551          dZZ_Ctab(k,i)=dZZ_Ci(k)
6552          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6553          dXX_XYZtab(k,i)=dXX_XYZ(k)
6554          dYY_XYZtab(k,i)=dYY_XYZ(k)
6555          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6556        enddo
6557
6558        do k = 1,3
6559 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6560 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6561 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6562 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6563 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6564 !     &    dt_dci(k)
6565 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6566 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6567          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6568           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6569          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6570           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6571          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6572           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6573        enddo
6574 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6575 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6576
6577 ! to check gradient call subroutine check_grad
6578
6579     1 continue
6580       enddo
6581       return
6582       end subroutine esc
6583 !-----------------------------------------------------------------------------
6584       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6585 !      implicit none
6586       real(kind=8),dimension(65) :: x
6587       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6588         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6589
6590       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6591         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6592         + x(10)*yy*zz
6593       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6594         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6595         + x(20)*yy*zz
6596       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6597         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6598         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6599         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6600         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6601         +x(40)*xx*yy*zz
6602       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6603         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6604         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6605         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6606         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6607         +x(60)*xx*yy*zz
6608       dsc_i   = 0.743d0+x(61)
6609       dp2_i   = 1.9d0+x(62)
6610       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6611                 *(xx*cost2+yy*sint2))
6612       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6613                 *(xx*cost2-yy*sint2))
6614       s1=(1+x(63))/(0.1d0 + dscp1)
6615       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6616       s2=(1+x(65))/(0.1d0 + dscp2)
6617       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6618       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6619        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6620       enesc=sumene
6621       return
6622       end function enesc
6623 #endif
6624 !-----------------------------------------------------------------------------
6625       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6626 !
6627 ! This procedure calculates two-body contact function g(rij) and its derivative:
6628 !
6629 !           eps0ij                                     !       x < -1
6630 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6631 !            0                                         !       x > 1
6632 !
6633 ! where x=(rij-r0ij)/delta
6634 !
6635 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6636 !
6637 !      implicit none
6638       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6639       real(kind=8) :: x,x2,x4,delta
6640 !     delta=0.02D0*r0ij
6641 !      delta=0.2D0*r0ij
6642       x=(rij-r0ij)/delta
6643       if (x.lt.-1.0D0) then
6644         fcont=eps0ij
6645         fprimcont=0.0D0
6646       else if (x.le.1.0D0) then
6647         x2=x*x
6648         x4=x2*x2
6649         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6650         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6651       else
6652         fcont=0.0D0
6653         fprimcont=0.0D0
6654       endif
6655       return
6656       end subroutine gcont
6657 !-----------------------------------------------------------------------------
6658       subroutine splinthet(theti,delta,ss,ssder)
6659 !      implicit real*8 (a-h,o-z)
6660 !      include 'DIMENSIONS'
6661 !      include 'COMMON.VAR'
6662 !      include 'COMMON.GEO'
6663       real(kind=8) :: theti,delta,ss,ssder
6664       real(kind=8) :: thetup,thetlow
6665       thetup=pi-delta
6666       thetlow=delta
6667       if (theti.gt.pipol) then
6668         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6669       else
6670         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6671         ssder=-ssder
6672       endif
6673       return
6674       end subroutine splinthet
6675 !-----------------------------------------------------------------------------
6676       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6677 !      implicit none
6678       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6679       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6680       a1=fprim0*delta/(f1-f0)
6681       a2=3.0d0-2.0d0*a1
6682       a3=a1-2.0d0
6683       ksi=(x-x0)/delta
6684       ksi2=ksi*ksi
6685       ksi3=ksi2*ksi
6686       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6687       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6688       return
6689       end subroutine spline1
6690 !-----------------------------------------------------------------------------
6691       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6692 !      implicit none
6693       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6694       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6695       ksi=(x-x0)/delta
6696       ksi2=ksi*ksi
6697       ksi3=ksi2*ksi
6698       a1=fprim0x*delta
6699       a2=3*(f1x-f0x)-2*fprim0x*delta
6700       a3=fprim0x*delta-2*(f1x-f0x)
6701       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6702       return
6703       end subroutine spline2
6704 !-----------------------------------------------------------------------------
6705 #ifdef CRYST_TOR
6706 !-----------------------------------------------------------------------------
6707       subroutine etor(etors,edihcnstr)
6708 !      implicit real*8 (a-h,o-z)
6709 !      include 'DIMENSIONS'
6710 !      include 'COMMON.VAR'
6711 !      include 'COMMON.GEO'
6712 !      include 'COMMON.LOCAL'
6713 !      include 'COMMON.TORSION'
6714 !      include 'COMMON.INTERACT'
6715 !      include 'COMMON.DERIV'
6716 !      include 'COMMON.CHAIN'
6717 !      include 'COMMON.NAMES'
6718 !      include 'COMMON.IOUNITS'
6719 !      include 'COMMON.FFIELD'
6720 !      include 'COMMON.TORCNSTR'
6721 !      include 'COMMON.CONTROL'
6722       real(kind=8) :: etors,edihcnstr
6723       logical :: lprn
6724 !el local variables
6725       integer :: i,j,
6726       real(kind=8) :: phii,fac,etors_ii
6727
6728 ! Set lprn=.true. for debugging
6729       lprn=.false.
6730 !      lprn=.true.
6731       etors=0.0D0
6732       do i=iphi_start,iphi_end
6733       etors_ii=0.0D0
6734         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6735             .or. itype(i,1).eq.ntyp1) cycle
6736         itori=itortyp(itype(i-2,1))
6737         itori1=itortyp(itype(i-1,1))
6738         phii=phi(i)
6739         gloci=0.0D0
6740 ! Proline-Proline pair is a special case...
6741         if (itori.eq.3 .and. itori1.eq.3) then
6742           if (phii.gt.-dwapi3) then
6743             cosphi=dcos(3*phii)
6744             fac=1.0D0/(1.0D0-cosphi)
6745             etorsi=v1(1,3,3)*fac
6746             etorsi=etorsi+etorsi
6747             etors=etors+etorsi-v1(1,3,3)
6748             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6749             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6750           endif
6751           do j=1,3
6752             v1ij=v1(j+1,itori,itori1)
6753             v2ij=v2(j+1,itori,itori1)
6754             cosphi=dcos(j*phii)
6755             sinphi=dsin(j*phii)
6756             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6757             if (energy_dec) etors_ii=etors_ii+ &
6758                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6759             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6760           enddo
6761         else
6762           do j=1,nterm_old
6763             v1ij=v1(j,itori,itori1)
6764             v2ij=v2(j,itori,itori1)
6765             cosphi=dcos(j*phii)
6766             sinphi=dsin(j*phii)
6767             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6768             if (energy_dec) etors_ii=etors_ii+ &
6769                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6770             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6771           enddo
6772         endif
6773         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6774              'etor',i,etors_ii
6775         if (lprn) &
6776         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6777         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6778         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6779         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6780 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6781       enddo
6782 ! 6/20/98 - dihedral angle constraints
6783       edihcnstr=0.0d0
6784       do i=1,ndih_constr
6785         itori=idih_constr(i)
6786         phii=phi(itori)
6787         difi=phii-phi0(i)
6788         if (difi.gt.drange(i)) then
6789           difi=difi-drange(i)
6790           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6791           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6792         else if (difi.lt.-drange(i)) then
6793           difi=difi+drange(i)
6794           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6795           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6796         endif
6797 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6798 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6799       enddo
6800 !      write (iout,*) 'edihcnstr',edihcnstr
6801       return
6802       end subroutine etor
6803 !-----------------------------------------------------------------------------
6804       subroutine etor_d(etors_d)
6805       real(kind=8) :: etors_d
6806       etors_d=0.0d0
6807       return
6808       end subroutine etor_d
6809 #else
6810 !-----------------------------------------------------------------------------
6811       subroutine etor(etors,edihcnstr)
6812 !      implicit real*8 (a-h,o-z)
6813 !      include 'DIMENSIONS'
6814 !      include 'COMMON.VAR'
6815 !      include 'COMMON.GEO'
6816 !      include 'COMMON.LOCAL'
6817 !      include 'COMMON.TORSION'
6818 !      include 'COMMON.INTERACT'
6819 !      include 'COMMON.DERIV'
6820 !      include 'COMMON.CHAIN'
6821 !      include 'COMMON.NAMES'
6822 !      include 'COMMON.IOUNITS'
6823 !      include 'COMMON.FFIELD'
6824 !      include 'COMMON.TORCNSTR'
6825 !      include 'COMMON.CONTROL'
6826       real(kind=8) :: etors,edihcnstr
6827       logical :: lprn
6828 !el local variables
6829       integer :: i,j,iblock,itori,itori1
6830       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6831                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6832 ! Set lprn=.true. for debugging
6833       lprn=.false.
6834 !     lprn=.true.
6835       etors=0.0D0
6836       do i=iphi_start,iphi_end
6837         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6838              .or. itype(i-3,1).eq.ntyp1 &
6839              .or. itype(i,1).eq.ntyp1) cycle
6840         etors_ii=0.0D0
6841          if (iabs(itype(i,1)).eq.20) then
6842          iblock=2
6843          else
6844          iblock=1
6845          endif
6846         itori=itortyp(itype(i-2,1))
6847         itori1=itortyp(itype(i-1,1))
6848         phii=phi(i)
6849         gloci=0.0D0
6850 ! Regular cosine and sine terms
6851         do j=1,nterm(itori,itori1,iblock)
6852           v1ij=v1(j,itori,itori1,iblock)
6853           v2ij=v2(j,itori,itori1,iblock)
6854           cosphi=dcos(j*phii)
6855           sinphi=dsin(j*phii)
6856           etors=etors+v1ij*cosphi+v2ij*sinphi
6857           if (energy_dec) etors_ii=etors_ii+ &
6858                      v1ij*cosphi+v2ij*sinphi
6859           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6860         enddo
6861 ! Lorentz terms
6862 !                         v1
6863 !  E = SUM ----------------------------------- - v1
6864 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6865 !
6866         cosphi=dcos(0.5d0*phii)
6867         sinphi=dsin(0.5d0*phii)
6868         do j=1,nlor(itori,itori1,iblock)
6869           vl1ij=vlor1(j,itori,itori1)
6870           vl2ij=vlor2(j,itori,itori1)
6871           vl3ij=vlor3(j,itori,itori1)
6872           pom=vl2ij*cosphi+vl3ij*sinphi
6873           pom1=1.0d0/(pom*pom+1.0d0)
6874           etors=etors+vl1ij*pom1
6875           if (energy_dec) etors_ii=etors_ii+ &
6876                      vl1ij*pom1
6877           pom=-pom*pom1*pom1
6878           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6879         enddo
6880 ! Subtract the constant term
6881         etors=etors-v0(itori,itori1,iblock)
6882           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6883                'etor',i,etors_ii-v0(itori,itori1,iblock)
6884         if (lprn) &
6885         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6886         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6887         (v1(j,itori,itori1,iblock),j=1,6),&
6888         (v2(j,itori,itori1,iblock),j=1,6)
6889         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6890 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6891       enddo
6892 ! 6/20/98 - dihedral angle constraints
6893       edihcnstr=0.0d0
6894 !      do i=1,ndih_constr
6895       do i=idihconstr_start,idihconstr_end
6896         itori=idih_constr(i)
6897         phii=phi(itori)
6898         difi=pinorm(phii-phi0(i))
6899         if (difi.gt.drange(i)) then
6900           difi=difi-drange(i)
6901           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6902           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6903         else if (difi.lt.-drange(i)) then
6904           difi=difi+drange(i)
6905           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6906           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6907         else
6908           difi=0.0
6909         endif
6910 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6911 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6912 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6913       enddo
6914 !d       write (iout,*) 'edihcnstr',edihcnstr
6915       return
6916       end subroutine etor
6917 !-----------------------------------------------------------------------------
6918       subroutine etor_d(etors_d)
6919 ! 6/23/01 Compute double torsional energy
6920 !      implicit real*8 (a-h,o-z)
6921 !      include 'DIMENSIONS'
6922 !      include 'COMMON.VAR'
6923 !      include 'COMMON.GEO'
6924 !      include 'COMMON.LOCAL'
6925 !      include 'COMMON.TORSION'
6926 !      include 'COMMON.INTERACT'
6927 !      include 'COMMON.DERIV'
6928 !      include 'COMMON.CHAIN'
6929 !      include 'COMMON.NAMES'
6930 !      include 'COMMON.IOUNITS'
6931 !      include 'COMMON.FFIELD'
6932 !      include 'COMMON.TORCNSTR'
6933       real(kind=8) :: etors_d,etors_d_ii
6934       logical :: lprn
6935 !el local variables
6936       integer :: i,j,k,l,itori,itori1,itori2,iblock
6937       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6938                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6939                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6940                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6941 ! Set lprn=.true. for debugging
6942       lprn=.false.
6943 !     lprn=.true.
6944       etors_d=0.0D0
6945 !      write(iout,*) "a tu??"
6946       do i=iphid_start,iphid_end
6947         etors_d_ii=0.0D0
6948         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6949             .or. itype(i-3,1).eq.ntyp1 &
6950             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6951         itori=itortyp(itype(i-2,1))
6952         itori1=itortyp(itype(i-1,1))
6953         itori2=itortyp(itype(i,1))
6954         phii=phi(i)
6955         phii1=phi(i+1)
6956         gloci1=0.0D0
6957         gloci2=0.0D0
6958         iblock=1
6959         if (iabs(itype(i+1,1)).eq.20) iblock=2
6960
6961 ! Regular cosine and sine terms
6962         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6963           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6964           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6965           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6966           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6967           cosphi1=dcos(j*phii)
6968           sinphi1=dsin(j*phii)
6969           cosphi2=dcos(j*phii1)
6970           sinphi2=dsin(j*phii1)
6971           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6972            v2cij*cosphi2+v2sij*sinphi2
6973           if (energy_dec) etors_d_ii=etors_d_ii+ &
6974            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6975           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6976           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6977         enddo
6978         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6979           do l=1,k-1
6980             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6981             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6982             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6983             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6984             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6985             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6986             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6987             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6988             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6989               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6990             if (energy_dec) etors_d_ii=etors_d_ii+ &
6991               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6992               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6993             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6994               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6995             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6996               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6997           enddo
6998         enddo
6999         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7000                             'etor_d',i,etors_d_ii
7001         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7002         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7003       enddo
7004       return
7005       end subroutine etor_d
7006 #endif
7007 !-----------------------------------------------------------------------------
7008       subroutine eback_sc_corr(esccor)
7009 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7010 !        conformational states; temporarily implemented as differences
7011 !        between UNRES torsional potentials (dependent on three types of
7012 !        residues) and the torsional potentials dependent on all 20 types
7013 !        of residues computed from AM1  energy surfaces of terminally-blocked
7014 !        amino-acid residues.
7015 !      implicit real*8 (a-h,o-z)
7016 !      include 'DIMENSIONS'
7017 !      include 'COMMON.VAR'
7018 !      include 'COMMON.GEO'
7019 !      include 'COMMON.LOCAL'
7020 !      include 'COMMON.TORSION'
7021 !      include 'COMMON.SCCOR'
7022 !      include 'COMMON.INTERACT'
7023 !      include 'COMMON.DERIV'
7024 !      include 'COMMON.CHAIN'
7025 !      include 'COMMON.NAMES'
7026 !      include 'COMMON.IOUNITS'
7027 !      include 'COMMON.FFIELD'
7028 !      include 'COMMON.CONTROL'
7029       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7030                    cosphi,sinphi
7031       logical :: lprn
7032       integer :: i,interty,j,isccori,isccori1,intertyp
7033 ! Set lprn=.true. for debugging
7034       lprn=.false.
7035 !      lprn=.true.
7036 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7037       esccor=0.0D0
7038       do i=itau_start,itau_end
7039         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7040         esccor_ii=0.0D0
7041         isccori=isccortyp(itype(i-2,1))
7042         isccori1=isccortyp(itype(i-1,1))
7043
7044 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7045         phii=phi(i)
7046         do intertyp=1,3 !intertyp
7047          esccor_ii=0.0D0
7048 !c Added 09 May 2012 (Adasko)
7049 !c  Intertyp means interaction type of backbone mainchain correlation:
7050 !   1 = SC...Ca...Ca...Ca
7051 !   2 = Ca...Ca...Ca...SC
7052 !   3 = SC...Ca...Ca...SCi
7053         gloci=0.0D0
7054         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7055             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7056             (itype(i-1,1).eq.ntyp1))) &
7057           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7058            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7059            .or.(itype(i,1).eq.ntyp1))) &
7060           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7061             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7062             (itype(i-3,1).eq.ntyp1)))) cycle
7063         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7064         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7065        cycle
7066        do j=1,nterm_sccor(isccori,isccori1)
7067           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7068           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7069           cosphi=dcos(j*tauangle(intertyp,i))
7070           sinphi=dsin(j*tauangle(intertyp,i))
7071           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7072           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7073           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7074         enddo
7075         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7076                                 'esccor',i,intertyp,esccor_ii
7077 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7078         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7079         if (lprn) &
7080         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7081         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7082         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7083         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7084         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7085        enddo !intertyp
7086       enddo
7087
7088       return
7089       end subroutine eback_sc_corr
7090 !-----------------------------------------------------------------------------
7091       subroutine multibody(ecorr)
7092 ! This subroutine calculates multi-body contributions to energy following
7093 ! the idea of Skolnick et al. If side chains I and J make a contact and
7094 ! at the same time side chains I+1 and J+1 make a contact, an extra
7095 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7096 !      implicit real*8 (a-h,o-z)
7097 !      include 'DIMENSIONS'
7098 !      include 'COMMON.IOUNITS'
7099 !      include 'COMMON.DERIV'
7100 !      include 'COMMON.INTERACT'
7101 !      include 'COMMON.CONTACTS'
7102       real(kind=8),dimension(3) :: gx,gx1
7103       logical :: lprn
7104       real(kind=8) :: ecorr
7105       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7106 ! Set lprn=.true. for debugging
7107       lprn=.false.
7108
7109       if (lprn) then
7110         write (iout,'(a)') 'Contact function values:'
7111         do i=nnt,nct-2
7112           write (iout,'(i2,20(1x,i2,f10.5))') &
7113               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7114         enddo
7115       endif
7116       ecorr=0.0D0
7117
7118 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7119 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7120       do i=nnt,nct
7121         do j=1,3
7122           gradcorr(j,i)=0.0D0
7123           gradxorr(j,i)=0.0D0
7124         enddo
7125       enddo
7126       do i=nnt,nct-2
7127
7128         DO ISHIFT = 3,4
7129
7130         i1=i+ishift
7131         num_conti=num_cont(i)
7132         num_conti1=num_cont(i1)
7133         do jj=1,num_conti
7134           j=jcont(jj,i)
7135           do kk=1,num_conti1
7136             j1=jcont(kk,i1)
7137             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7138 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7139 !d   &                   ' ishift=',ishift
7140 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7141 ! The system gains extra energy.
7142               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7143             endif   ! j1==j+-ishift
7144           enddo     ! kk
7145         enddo       ! jj
7146
7147         ENDDO ! ISHIFT
7148
7149       enddo         ! i
7150       return
7151       end subroutine multibody
7152 !-----------------------------------------------------------------------------
7153       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7154 !      implicit real*8 (a-h,o-z)
7155 !      include 'DIMENSIONS'
7156 !      include 'COMMON.IOUNITS'
7157 !      include 'COMMON.DERIV'
7158 !      include 'COMMON.INTERACT'
7159 !      include 'COMMON.CONTACTS'
7160       real(kind=8),dimension(3) :: gx,gx1
7161       logical :: lprn
7162       integer :: i,j,k,l,jj,kk,m,ll
7163       real(kind=8) :: eij,ekl
7164       lprn=.false.
7165       eij=facont(jj,i)
7166       ekl=facont(kk,k)
7167 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7168 ! Calculate the multi-body contribution to energy.
7169 ! Calculate multi-body contributions to the gradient.
7170 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7171 !d   & k,l,(gacont(m,kk,k),m=1,3)
7172       do m=1,3
7173         gx(m) =ekl*gacont(m,jj,i)
7174         gx1(m)=eij*gacont(m,kk,k)
7175         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7176         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7177         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7178         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7179       enddo
7180       do m=i,j-1
7181         do ll=1,3
7182           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7183         enddo
7184       enddo
7185       do m=k,l-1
7186         do ll=1,3
7187           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7188         enddo
7189       enddo
7190       esccorr=-eij*ekl
7191       return
7192       end function esccorr
7193 !-----------------------------------------------------------------------------
7194       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7195 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7196 !      implicit real*8 (a-h,o-z)
7197 !      include 'DIMENSIONS'
7198 !      include 'COMMON.IOUNITS'
7199 #ifdef MPI
7200       include "mpif.h"
7201 !      integer :: maxconts !max_cont=maxconts  =nres/4
7202       integer,parameter :: max_dim=26
7203       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7204       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7205 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7206 !el      common /przechowalnia/ zapas
7207       integer :: status(MPI_STATUS_SIZE)
7208       integer,dimension((nres/4)*2) :: req !maxconts*2
7209       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7210 #endif
7211 !      include 'COMMON.SETUP'
7212 !      include 'COMMON.FFIELD'
7213 !      include 'COMMON.DERIV'
7214 !      include 'COMMON.INTERACT'
7215 !      include 'COMMON.CONTACTS'
7216 !      include 'COMMON.CONTROL'
7217 !      include 'COMMON.LOCAL'
7218       real(kind=8),dimension(3) :: gx,gx1
7219       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7220       logical :: lprn,ldone
7221 !el local variables
7222       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7223               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7224
7225 ! Set lprn=.true. for debugging
7226       lprn=.false.
7227 #ifdef MPI
7228 !      maxconts=nres/4
7229       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7230       n_corr=0
7231       n_corr1=0
7232       if (nfgtasks.le.1) goto 30
7233       if (lprn) then
7234         write (iout,'(a)') 'Contact function values before RECEIVE:'
7235         do i=nnt,nct-2
7236           write (iout,'(2i3,50(1x,i2,f5.2))') &
7237           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7238           j=1,num_cont_hb(i))
7239         enddo
7240       endif
7241       call flush(iout)
7242       do i=1,ntask_cont_from
7243         ncont_recv(i)=0
7244       enddo
7245       do i=1,ntask_cont_to
7246         ncont_sent(i)=0
7247       enddo
7248 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7249 !     & ntask_cont_to
7250 ! Make the list of contacts to send to send to other procesors
7251 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7252 !      call flush(iout)
7253       do i=iturn3_start,iturn3_end
7254 !        write (iout,*) "make contact list turn3",i," num_cont",
7255 !     &    num_cont_hb(i)
7256         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7257       enddo
7258       do i=iturn4_start,iturn4_end
7259 !        write (iout,*) "make contact list turn4",i," num_cont",
7260 !     &   num_cont_hb(i)
7261         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7262       enddo
7263       do ii=1,nat_sent
7264         i=iat_sent(ii)
7265 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7266 !     &    num_cont_hb(i)
7267         do j=1,num_cont_hb(i)
7268         do k=1,4
7269           jjc=jcont_hb(j,i)
7270           iproc=iint_sent_local(k,jjc,ii)
7271 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7272           if (iproc.gt.0) then
7273             ncont_sent(iproc)=ncont_sent(iproc)+1
7274             nn=ncont_sent(iproc)
7275             zapas(1,nn,iproc)=i
7276             zapas(2,nn,iproc)=jjc
7277             zapas(3,nn,iproc)=facont_hb(j,i)
7278             zapas(4,nn,iproc)=ees0p(j,i)
7279             zapas(5,nn,iproc)=ees0m(j,i)
7280             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7281             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7282             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7283             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7284             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7285             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7286             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7287             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7288             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7289             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7290             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7291             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7292             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7293             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7294             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7295             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7296             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7297             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7298             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7299             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7300             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7301           endif
7302         enddo
7303         enddo
7304       enddo
7305       if (lprn) then
7306       write (iout,*) &
7307         "Numbers of contacts to be sent to other processors",&
7308         (ncont_sent(i),i=1,ntask_cont_to)
7309       write (iout,*) "Contacts sent"
7310       do ii=1,ntask_cont_to
7311         nn=ncont_sent(ii)
7312         iproc=itask_cont_to(ii)
7313         write (iout,*) nn," contacts to processor",iproc,&
7314          " of CONT_TO_COMM group"
7315         do i=1,nn
7316           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7317         enddo
7318       enddo
7319       call flush(iout)
7320       endif
7321       CorrelType=477
7322       CorrelID=fg_rank+1
7323       CorrelType1=478
7324       CorrelID1=nfgtasks+fg_rank+1
7325       ireq=0
7326 ! Receive the numbers of needed contacts from other processors
7327       do ii=1,ntask_cont_from
7328         iproc=itask_cont_from(ii)
7329         ireq=ireq+1
7330         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7331           FG_COMM,req(ireq),IERR)
7332       enddo
7333 !      write (iout,*) "IRECV ended"
7334 !      call flush(iout)
7335 ! Send the number of contacts needed by other processors
7336       do ii=1,ntask_cont_to
7337         iproc=itask_cont_to(ii)
7338         ireq=ireq+1
7339         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7340           FG_COMM,req(ireq),IERR)
7341       enddo
7342 !      write (iout,*) "ISEND ended"
7343 !      write (iout,*) "number of requests (nn)",ireq
7344       call flush(iout)
7345       if (ireq.gt.0) &
7346         call MPI_Waitall(ireq,req,status_array,ierr)
7347 !      write (iout,*)
7348 !     &  "Numbers of contacts to be received from other processors",
7349 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7350 !      call flush(iout)
7351 ! Receive contacts
7352       ireq=0
7353       do ii=1,ntask_cont_from
7354         iproc=itask_cont_from(ii)
7355         nn=ncont_recv(ii)
7356 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7357 !     &   " of CONT_TO_COMM group"
7358         call flush(iout)
7359         if (nn.gt.0) then
7360           ireq=ireq+1
7361           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7362           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7363 !          write (iout,*) "ireq,req",ireq,req(ireq)
7364         endif
7365       enddo
7366 ! Send the contacts to processors that need them
7367       do ii=1,ntask_cont_to
7368         iproc=itask_cont_to(ii)
7369         nn=ncont_sent(ii)
7370 !        write (iout,*) nn," contacts to processor",iproc,
7371 !     &   " of CONT_TO_COMM group"
7372         if (nn.gt.0) then
7373           ireq=ireq+1
7374           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7375             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7376 !          write (iout,*) "ireq,req",ireq,req(ireq)
7377 !          do i=1,nn
7378 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7379 !          enddo
7380         endif
7381       enddo
7382 !      write (iout,*) "number of requests (contacts)",ireq
7383 !      write (iout,*) "req",(req(i),i=1,4)
7384 !      call flush(iout)
7385       if (ireq.gt.0) &
7386        call MPI_Waitall(ireq,req,status_array,ierr)
7387       do iii=1,ntask_cont_from
7388         iproc=itask_cont_from(iii)
7389         nn=ncont_recv(iii)
7390         if (lprn) then
7391         write (iout,*) "Received",nn," contacts from processor",iproc,&
7392          " of CONT_FROM_COMM group"
7393         call flush(iout)
7394         do i=1,nn
7395           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7396         enddo
7397         call flush(iout)
7398         endif
7399         do i=1,nn
7400           ii=zapas_recv(1,i,iii)
7401 ! Flag the received contacts to prevent double-counting
7402           jj=-zapas_recv(2,i,iii)
7403 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7404 !          call flush(iout)
7405           nnn=num_cont_hb(ii)+1
7406           num_cont_hb(ii)=nnn
7407           jcont_hb(nnn,ii)=jj
7408           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7409           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7410           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7411           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7412           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7413           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7414           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7415           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7416           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7417           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7418           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7419           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7420           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7421           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7422           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7423           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7424           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7425           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7426           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7427           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7428           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7429           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7430           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7431           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7432         enddo
7433       enddo
7434       call flush(iout)
7435       if (lprn) then
7436         write (iout,'(a)') 'Contact function values after receive:'
7437         do i=nnt,nct-2
7438           write (iout,'(2i3,50(1x,i3,f5.2))') &
7439           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7440           j=1,num_cont_hb(i))
7441         enddo
7442         call flush(iout)
7443       endif
7444    30 continue
7445 #endif
7446       if (lprn) then
7447         write (iout,'(a)') 'Contact function values:'
7448         do i=nnt,nct-2
7449           write (iout,'(2i3,50(1x,i3,f5.2))') &
7450           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7451           j=1,num_cont_hb(i))
7452         enddo
7453       endif
7454       ecorr=0.0D0
7455
7456 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7457 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7458 ! Remove the loop below after debugging !!!
7459       do i=nnt,nct
7460         do j=1,3
7461           gradcorr(j,i)=0.0D0
7462           gradxorr(j,i)=0.0D0
7463         enddo
7464       enddo
7465 ! Calculate the local-electrostatic correlation terms
7466       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7467         i1=i+1
7468         num_conti=num_cont_hb(i)
7469         num_conti1=num_cont_hb(i+1)
7470         do jj=1,num_conti
7471           j=jcont_hb(jj,i)
7472           jp=iabs(j)
7473           do kk=1,num_conti1
7474             j1=jcont_hb(kk,i1)
7475             jp1=iabs(j1)
7476 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7477 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7478             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7479                 .or. j.lt.0 .and. j1.gt.0) .and. &
7480                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7481 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7482 ! The system gains extra energy.
7483               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7484               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7485                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7486               n_corr=n_corr+1
7487             else if (j1.eq.j) then
7488 ! Contacts I-J and I-(J+1) occur simultaneously.
7489 ! The system loses extra energy.
7490 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7491             endif
7492           enddo ! kk
7493           do kk=1,num_conti
7494             j1=jcont_hb(kk,i)
7495 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7496 !    &         ' jj=',jj,' kk=',kk
7497             if (j1.eq.j+1) then
7498 ! Contacts I-J and (I+1)-J occur simultaneously.
7499 ! The system loses extra energy.
7500 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7501             endif ! j1==j+1
7502           enddo ! kk
7503         enddo ! jj
7504       enddo ! i
7505       return
7506       end subroutine multibody_hb
7507 !-----------------------------------------------------------------------------
7508       subroutine add_hb_contact(ii,jj,itask)
7509 !      implicit real*8 (a-h,o-z)
7510 !      include "DIMENSIONS"
7511 !      include "COMMON.IOUNITS"
7512 !      include "COMMON.CONTACTS"
7513 !      integer,parameter :: maxconts=nres/4
7514       integer,parameter :: max_dim=26
7515       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7516 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7517 !      common /przechowalnia/ zapas
7518       integer :: i,j,ii,jj,iproc,nn,jjc
7519       integer,dimension(4) :: itask
7520 !      write (iout,*) "itask",itask
7521       do i=1,2
7522         iproc=itask(i)
7523         if (iproc.gt.0) then
7524           do j=1,num_cont_hb(ii)
7525             jjc=jcont_hb(j,ii)
7526 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7527             if (jjc.eq.jj) then
7528               ncont_sent(iproc)=ncont_sent(iproc)+1
7529               nn=ncont_sent(iproc)
7530               zapas(1,nn,iproc)=ii
7531               zapas(2,nn,iproc)=jjc
7532               zapas(3,nn,iproc)=facont_hb(j,ii)
7533               zapas(4,nn,iproc)=ees0p(j,ii)
7534               zapas(5,nn,iproc)=ees0m(j,ii)
7535               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7536               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7537               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7538               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7539               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7540               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7541               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7542               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7543               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7544               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7545               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7546               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7547               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7548               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7549               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7550               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7551               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7552               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7553               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7554               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7555               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7556               exit
7557             endif
7558           enddo
7559         endif
7560       enddo
7561       return
7562       end subroutine add_hb_contact
7563 !-----------------------------------------------------------------------------
7564       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7565 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7566 !      implicit real*8 (a-h,o-z)
7567 !      include 'DIMENSIONS'
7568 !      include 'COMMON.IOUNITS'
7569       integer,parameter :: max_dim=70
7570 #ifdef MPI
7571       include "mpif.h"
7572 !      integer :: maxconts !max_cont=maxconts=nres/4
7573       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7574       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7575 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7576 !      common /przechowalnia/ zapas
7577       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7578         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7579         ierr,iii,nnn
7580 #endif
7581 !      include 'COMMON.SETUP'
7582 !      include 'COMMON.FFIELD'
7583 !      include 'COMMON.DERIV'
7584 !      include 'COMMON.LOCAL'
7585 !      include 'COMMON.INTERACT'
7586 !      include 'COMMON.CONTACTS'
7587 !      include 'COMMON.CHAIN'
7588 !      include 'COMMON.CONTROL'
7589       real(kind=8),dimension(3) :: gx,gx1
7590       integer,dimension(nres) :: num_cont_hb_old
7591       logical :: lprn,ldone
7592 !EL      double precision eello4,eello5,eelo6,eello_turn6
7593 !EL      external eello4,eello5,eello6,eello_turn6
7594 !el local variables
7595       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7596               j1,jp1,i1,num_conti1
7597       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7598       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7599
7600 ! Set lprn=.true. for debugging
7601       lprn=.false.
7602       eturn6=0.0d0
7603 #ifdef MPI
7604 !      maxconts=nres/4
7605       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7606       do i=1,nres
7607         num_cont_hb_old(i)=num_cont_hb(i)
7608       enddo
7609       n_corr=0
7610       n_corr1=0
7611       if (nfgtasks.le.1) goto 30
7612       if (lprn) then
7613         write (iout,'(a)') 'Contact function values before RECEIVE:'
7614         do i=nnt,nct-2
7615           write (iout,'(2i3,50(1x,i2,f5.2))') &
7616           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7617           j=1,num_cont_hb(i))
7618         enddo
7619       endif
7620       call flush(iout)
7621       do i=1,ntask_cont_from
7622         ncont_recv(i)=0
7623       enddo
7624       do i=1,ntask_cont_to
7625         ncont_sent(i)=0
7626       enddo
7627 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7628 !     & ntask_cont_to
7629 ! Make the list of contacts to send to send to other procesors
7630       do i=iturn3_start,iturn3_end
7631 !        write (iout,*) "make contact list turn3",i," num_cont",
7632 !     &    num_cont_hb(i)
7633         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7634       enddo
7635       do i=iturn4_start,iturn4_end
7636 !        write (iout,*) "make contact list turn4",i," num_cont",
7637 !     &   num_cont_hb(i)
7638         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7639       enddo
7640       do ii=1,nat_sent
7641         i=iat_sent(ii)
7642 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7643 !     &    num_cont_hb(i)
7644         do j=1,num_cont_hb(i)
7645         do k=1,4
7646           jjc=jcont_hb(j,i)
7647           iproc=iint_sent_local(k,jjc,ii)
7648 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7649           if (iproc.ne.0) then
7650             ncont_sent(iproc)=ncont_sent(iproc)+1
7651             nn=ncont_sent(iproc)
7652             zapas(1,nn,iproc)=i
7653             zapas(2,nn,iproc)=jjc
7654             zapas(3,nn,iproc)=d_cont(j,i)
7655             ind=3
7656             do kk=1,3
7657               ind=ind+1
7658               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7659             enddo
7660             do kk=1,2
7661               do ll=1,2
7662                 ind=ind+1
7663                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7664               enddo
7665             enddo
7666             do jj=1,5
7667               do kk=1,3
7668                 do ll=1,2
7669                   do mm=1,2
7670                     ind=ind+1
7671                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7672                   enddo
7673                 enddo
7674               enddo
7675             enddo
7676           endif
7677         enddo
7678         enddo
7679       enddo
7680       if (lprn) then
7681       write (iout,*) &
7682         "Numbers of contacts to be sent to other processors",&
7683         (ncont_sent(i),i=1,ntask_cont_to)
7684       write (iout,*) "Contacts sent"
7685       do ii=1,ntask_cont_to
7686         nn=ncont_sent(ii)
7687         iproc=itask_cont_to(ii)
7688         write (iout,*) nn," contacts to processor",iproc,&
7689          " of CONT_TO_COMM group"
7690         do i=1,nn
7691           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7692         enddo
7693       enddo
7694       call flush(iout)
7695       endif
7696       CorrelType=477
7697       CorrelID=fg_rank+1
7698       CorrelType1=478
7699       CorrelID1=nfgtasks+fg_rank+1
7700       ireq=0
7701 ! Receive the numbers of needed contacts from other processors
7702       do ii=1,ntask_cont_from
7703         iproc=itask_cont_from(ii)
7704         ireq=ireq+1
7705         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7706           FG_COMM,req(ireq),IERR)
7707       enddo
7708 !      write (iout,*) "IRECV ended"
7709 !      call flush(iout)
7710 ! Send the number of contacts needed by other processors
7711       do ii=1,ntask_cont_to
7712         iproc=itask_cont_to(ii)
7713         ireq=ireq+1
7714         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7715           FG_COMM,req(ireq),IERR)
7716       enddo
7717 !      write (iout,*) "ISEND ended"
7718 !      write (iout,*) "number of requests (nn)",ireq
7719       call flush(iout)
7720       if (ireq.gt.0) &
7721         call MPI_Waitall(ireq,req,status_array,ierr)
7722 !      write (iout,*)
7723 !     &  "Numbers of contacts to be received from other processors",
7724 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7725 !      call flush(iout)
7726 ! Receive contacts
7727       ireq=0
7728       do ii=1,ntask_cont_from
7729         iproc=itask_cont_from(ii)
7730         nn=ncont_recv(ii)
7731 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7732 !     &   " of CONT_TO_COMM group"
7733         call flush(iout)
7734         if (nn.gt.0) then
7735           ireq=ireq+1
7736           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7737           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7738 !          write (iout,*) "ireq,req",ireq,req(ireq)
7739         endif
7740       enddo
7741 ! Send the contacts to processors that need them
7742       do ii=1,ntask_cont_to
7743         iproc=itask_cont_to(ii)
7744         nn=ncont_sent(ii)
7745 !        write (iout,*) nn," contacts to processor",iproc,
7746 !     &   " of CONT_TO_COMM group"
7747         if (nn.gt.0) then
7748           ireq=ireq+1
7749           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7750             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7751 !          write (iout,*) "ireq,req",ireq,req(ireq)
7752 !          do i=1,nn
7753 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7754 !          enddo
7755         endif
7756       enddo
7757 !      write (iout,*) "number of requests (contacts)",ireq
7758 !      write (iout,*) "req",(req(i),i=1,4)
7759 !      call flush(iout)
7760       if (ireq.gt.0) &
7761        call MPI_Waitall(ireq,req,status_array,ierr)
7762       do iii=1,ntask_cont_from
7763         iproc=itask_cont_from(iii)
7764         nn=ncont_recv(iii)
7765         if (lprn) then
7766         write (iout,*) "Received",nn," contacts from processor",iproc,&
7767          " of CONT_FROM_COMM group"
7768         call flush(iout)
7769         do i=1,nn
7770           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7771         enddo
7772         call flush(iout)
7773         endif
7774         do i=1,nn
7775           ii=zapas_recv(1,i,iii)
7776 ! Flag the received contacts to prevent double-counting
7777           jj=-zapas_recv(2,i,iii)
7778 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7779 !          call flush(iout)
7780           nnn=num_cont_hb(ii)+1
7781           num_cont_hb(ii)=nnn
7782           jcont_hb(nnn,ii)=jj
7783           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7784           ind=3
7785           do kk=1,3
7786             ind=ind+1
7787             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7788           enddo
7789           do kk=1,2
7790             do ll=1,2
7791               ind=ind+1
7792               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7793             enddo
7794           enddo
7795           do jj=1,5
7796             do kk=1,3
7797               do ll=1,2
7798                 do mm=1,2
7799                   ind=ind+1
7800                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7801                 enddo
7802               enddo
7803             enddo
7804           enddo
7805         enddo
7806       enddo
7807       call flush(iout)
7808       if (lprn) then
7809         write (iout,'(a)') 'Contact function values after receive:'
7810         do i=nnt,nct-2
7811           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7812           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7813           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7814         enddo
7815         call flush(iout)
7816       endif
7817    30 continue
7818 #endif
7819       if (lprn) then
7820         write (iout,'(a)') 'Contact function values:'
7821         do i=nnt,nct-2
7822           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7823           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7824           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7825         enddo
7826       endif
7827       ecorr=0.0D0
7828       ecorr5=0.0d0
7829       ecorr6=0.0d0
7830
7831 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7832 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7833 ! Remove the loop below after debugging !!!
7834       do i=nnt,nct
7835         do j=1,3
7836           gradcorr(j,i)=0.0D0
7837           gradxorr(j,i)=0.0D0
7838         enddo
7839       enddo
7840 ! Calculate the dipole-dipole interaction energies
7841       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7842       do i=iatel_s,iatel_e+1
7843         num_conti=num_cont_hb(i)
7844         do jj=1,num_conti
7845           j=jcont_hb(jj,i)
7846 #ifdef MOMENT
7847           call dipole(i,j,jj)
7848 #endif
7849         enddo
7850       enddo
7851       endif
7852 ! Calculate the local-electrostatic correlation terms
7853 !                write (iout,*) "gradcorr5 in eello5 before loop"
7854 !                do iii=1,nres
7855 !                  write (iout,'(i5,3f10.5)')
7856 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7857 !                enddo
7858       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7859 !        write (iout,*) "corr loop i",i
7860         i1=i+1
7861         num_conti=num_cont_hb(i)
7862         num_conti1=num_cont_hb(i+1)
7863         do jj=1,num_conti
7864           j=jcont_hb(jj,i)
7865           jp=iabs(j)
7866           do kk=1,num_conti1
7867             j1=jcont_hb(kk,i1)
7868             jp1=iabs(j1)
7869 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7870 !     &         ' jj=',jj,' kk=',kk
7871 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7872             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7873                 .or. j.lt.0 .and. j1.gt.0) .and. &
7874                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7875 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7876 ! The system gains extra energy.
7877               n_corr=n_corr+1
7878               sqd1=dsqrt(d_cont(jj,i))
7879               sqd2=dsqrt(d_cont(kk,i1))
7880               sred_geom = sqd1*sqd2
7881               IF (sred_geom.lt.cutoff_corr) THEN
7882                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7883                   ekont,fprimcont)
7884 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7885 !d     &         ' jj=',jj,' kk=',kk
7886                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7887                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7888                 do l=1,3
7889                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7890                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7891                 enddo
7892                 n_corr1=n_corr1+1
7893 !d               write (iout,*) 'sred_geom=',sred_geom,
7894 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7895 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7896 !d               write (iout,*) "g_contij",g_contij
7897 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7898 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7899                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7900                 if (wcorr4.gt.0.0d0) &
7901                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7902                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7903                        write (iout,'(a6,4i5,0pf7.3)') &
7904                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7905 !                write (iout,*) "gradcorr5 before eello5"
7906 !                do iii=1,nres
7907 !                  write (iout,'(i5,3f10.5)')
7908 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7909 !                enddo
7910                 if (wcorr5.gt.0.0d0) &
7911                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7912 !                write (iout,*) "gradcorr5 after eello5"
7913 !                do iii=1,nres
7914 !                  write (iout,'(i5,3f10.5)')
7915 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7916 !                enddo
7917                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7918                        write (iout,'(a6,4i5,0pf7.3)') &
7919                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7920 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7921 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7922                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7923                      .or. wturn6.eq.0.0d0))then
7924 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7925                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7926                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7927                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7928 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7929 !d     &            'ecorr6=',ecorr6
7930 !d                write (iout,'(4e15.5)') sred_geom,
7931 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7932 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7933 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7934                 else if (wturn6.gt.0.0d0 &
7935                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7936 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7937                   eturn6=eturn6+eello_turn6(i,jj,kk)
7938                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7939                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7940 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7941                 endif
7942               ENDIF
7943 1111          continue
7944             endif
7945           enddo ! kk
7946         enddo ! jj
7947       enddo ! i
7948       do i=1,nres
7949         num_cont_hb(i)=num_cont_hb_old(i)
7950       enddo
7951 !                write (iout,*) "gradcorr5 in eello5"
7952 !                do iii=1,nres
7953 !                  write (iout,'(i5,3f10.5)')
7954 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7955 !                enddo
7956       return
7957       end subroutine multibody_eello
7958 !-----------------------------------------------------------------------------
7959       subroutine add_hb_contact_eello(ii,jj,itask)
7960 !      implicit real*8 (a-h,o-z)
7961 !      include "DIMENSIONS"
7962 !      include "COMMON.IOUNITS"
7963 !      include "COMMON.CONTACTS"
7964 !      integer,parameter :: maxconts=nres/4
7965       integer,parameter :: max_dim=70
7966       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7967 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7968 !      common /przechowalnia/ zapas
7969
7970       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7971       integer,dimension(4) ::itask
7972 !      write (iout,*) "itask",itask
7973       do i=1,2
7974         iproc=itask(i)
7975         if (iproc.gt.0) then
7976           do j=1,num_cont_hb(ii)
7977             jjc=jcont_hb(j,ii)
7978 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7979             if (jjc.eq.jj) then
7980               ncont_sent(iproc)=ncont_sent(iproc)+1
7981               nn=ncont_sent(iproc)
7982               zapas(1,nn,iproc)=ii
7983               zapas(2,nn,iproc)=jjc
7984               zapas(3,nn,iproc)=d_cont(j,ii)
7985               ind=3
7986               do kk=1,3
7987                 ind=ind+1
7988                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7989               enddo
7990               do kk=1,2
7991                 do ll=1,2
7992                   ind=ind+1
7993                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7994                 enddo
7995               enddo
7996               do jj=1,5
7997                 do kk=1,3
7998                   do ll=1,2
7999                     do mm=1,2
8000                       ind=ind+1
8001                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8002                     enddo
8003                   enddo
8004                 enddo
8005               enddo
8006               exit
8007             endif
8008           enddo
8009         endif
8010       enddo
8011       return
8012       end subroutine add_hb_contact_eello
8013 !-----------------------------------------------------------------------------
8014       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8015 !      implicit real*8 (a-h,o-z)
8016 !      include 'DIMENSIONS'
8017 !      include 'COMMON.IOUNITS'
8018 !      include 'COMMON.DERIV'
8019 !      include 'COMMON.INTERACT'
8020 !      include 'COMMON.CONTACTS'
8021       real(kind=8),dimension(3) :: gx,gx1
8022       logical :: lprn
8023 !el local variables
8024       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8025       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8026                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8027                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8028                    rlocshield
8029
8030       lprn=.false.
8031       eij=facont_hb(jj,i)
8032       ekl=facont_hb(kk,k)
8033       ees0pij=ees0p(jj,i)
8034       ees0pkl=ees0p(kk,k)
8035       ees0mij=ees0m(jj,i)
8036       ees0mkl=ees0m(kk,k)
8037       ekont=eij*ekl
8038       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8039 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8040 ! Following 4 lines for diagnostics.
8041 !d    ees0pkl=0.0D0
8042 !d    ees0pij=1.0D0
8043 !d    ees0mkl=0.0D0
8044 !d    ees0mij=1.0D0
8045 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8046 !     & 'Contacts ',i,j,
8047 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8048 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8049 !     & 'gradcorr_long'
8050 ! Calculate the multi-body contribution to energy.
8051 !      ecorr=ecorr+ekont*ees
8052 ! Calculate multi-body contributions to the gradient.
8053       coeffpees0pij=coeffp*ees0pij
8054       coeffmees0mij=coeffm*ees0mij
8055       coeffpees0pkl=coeffp*ees0pkl
8056       coeffmees0mkl=coeffm*ees0mkl
8057       do ll=1,3
8058 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8059         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8060         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8061         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8062         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8063         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8064         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8065 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8066         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8067         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8068         coeffmees0mij*gacontm_hb1(ll,kk,k))
8069         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8070         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8071         coeffmees0mij*gacontm_hb2(ll,kk,k))
8072         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8073            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8074            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8075         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8076         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8077         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8078            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8079            coeffmees0mij*gacontm_hb3(ll,kk,k))
8080         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8081         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8082 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8083       enddo
8084 !      write (iout,*)
8085 !grad      do m=i+1,j-1
8086 !grad        do ll=1,3
8087 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8088 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8089 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8090 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8091 !grad        enddo
8092 !grad      enddo
8093 !grad      do m=k+1,l-1
8094 !grad        do ll=1,3
8095 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8096 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8097 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8098 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8099 !grad        enddo
8100 !grad      enddo
8101 !      write (iout,*) "ehbcorr",ekont*ees
8102       ehbcorr=ekont*ees
8103       if (shield_mode.gt.0) then
8104        j=ees0plist(jj,i)
8105        l=ees0plist(kk,k)
8106 !C        print *,i,j,fac_shield(i),fac_shield(j),
8107 !C     &fac_shield(k),fac_shield(l)
8108         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8109            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8110           do ilist=1,ishield_list(i)
8111            iresshield=shield_list(ilist,i)
8112            do m=1,3
8113            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8114            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8115                    rlocshield  &
8116             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8117             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8118             +rlocshield
8119            enddo
8120           enddo
8121           do ilist=1,ishield_list(j)
8122            iresshield=shield_list(ilist,j)
8123            do m=1,3
8124            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8125            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8126                    rlocshield &
8127             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8128            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8129             +rlocshield
8130            enddo
8131           enddo
8132
8133           do ilist=1,ishield_list(k)
8134            iresshield=shield_list(ilist,k)
8135            do m=1,3
8136            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8137            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8138                    rlocshield &
8139             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8140            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8141             +rlocshield
8142            enddo
8143           enddo
8144           do ilist=1,ishield_list(l)
8145            iresshield=shield_list(ilist,l)
8146            do m=1,3
8147            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8148            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8149                    rlocshield &
8150             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8151            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8152             +rlocshield
8153            enddo
8154           enddo
8155           do m=1,3
8156             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8157                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8158             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8159                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8160             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8161                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8162             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8163                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8164
8165             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8166                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8167             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8168                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8169             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8170                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8171             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8172                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8173
8174            enddo
8175       endif
8176       endif
8177       return
8178       end function ehbcorr
8179 #ifdef MOMENT
8180 !-----------------------------------------------------------------------------
8181       subroutine dipole(i,j,jj)
8182 !      implicit real*8 (a-h,o-z)
8183 !      include 'DIMENSIONS'
8184 !      include 'COMMON.IOUNITS'
8185 !      include 'COMMON.CHAIN'
8186 !      include 'COMMON.FFIELD'
8187 !      include 'COMMON.DERIV'
8188 !      include 'COMMON.INTERACT'
8189 !      include 'COMMON.CONTACTS'
8190 !      include 'COMMON.TORSION'
8191 !      include 'COMMON.VAR'
8192 !      include 'COMMON.GEO'
8193       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8194       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8195       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8196
8197       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8198       allocate(dipderx(3,5,4,maxconts,nres))
8199 !
8200
8201       iti1 = itortyp(itype(i+1,1))
8202       if (j.lt.nres-1) then
8203         itj1 = itortyp(itype(j+1,1))
8204       else
8205         itj1=ntortyp+1
8206       endif
8207       do iii=1,2
8208         dipi(iii,1)=Ub2(iii,i)
8209         dipderi(iii)=Ub2der(iii,i)
8210         dipi(iii,2)=b1(iii,iti1)
8211         dipj(iii,1)=Ub2(iii,j)
8212         dipderj(iii)=Ub2der(iii,j)
8213         dipj(iii,2)=b1(iii,itj1)
8214       enddo
8215       kkk=0
8216       do iii=1,2
8217         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8218         do jjj=1,2
8219           kkk=kkk+1
8220           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8221         enddo
8222       enddo
8223       do kkk=1,5
8224         do lll=1,3
8225           mmm=0
8226           do iii=1,2
8227             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8228               auxvec(1))
8229             do jjj=1,2
8230               mmm=mmm+1
8231               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8232             enddo
8233           enddo
8234         enddo
8235       enddo
8236       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8237       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8238       do iii=1,2
8239         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8240       enddo
8241       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8242       do iii=1,2
8243         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8244       enddo
8245       return
8246       end subroutine dipole
8247 #endif
8248 !-----------------------------------------------------------------------------
8249       subroutine calc_eello(i,j,k,l,jj,kk)
8250 !
8251 ! This subroutine computes matrices and vectors needed to calculate
8252 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8253 !
8254       use comm_kut
8255 !      implicit real*8 (a-h,o-z)
8256 !      include 'DIMENSIONS'
8257 !      include 'COMMON.IOUNITS'
8258 !      include 'COMMON.CHAIN'
8259 !      include 'COMMON.DERIV'
8260 !      include 'COMMON.INTERACT'
8261 !      include 'COMMON.CONTACTS'
8262 !      include 'COMMON.TORSION'
8263 !      include 'COMMON.VAR'
8264 !      include 'COMMON.GEO'
8265 !      include 'COMMON.FFIELD'
8266       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8267       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8268       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8269               itj1
8270 !el      logical :: lprn
8271 !el      common /kutas/ lprn
8272 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8273 !d     & ' jj=',jj,' kk=',kk
8274 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8275 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8276 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8277       do iii=1,2
8278         do jjj=1,2
8279           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8280           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8281         enddo
8282       enddo
8283       call transpose2(aa1(1,1),aa1t(1,1))
8284       call transpose2(aa2(1,1),aa2t(1,1))
8285       do kkk=1,5
8286         do lll=1,3
8287           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8288             aa1tder(1,1,lll,kkk))
8289           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8290             aa2tder(1,1,lll,kkk))
8291         enddo
8292       enddo
8293       if (l.eq.j+1) then
8294 ! parallel orientation of the two CA-CA-CA frames.
8295         if (i.gt.1) then
8296           iti=itortyp(itype(i,1))
8297         else
8298           iti=ntortyp+1
8299         endif
8300         itk1=itortyp(itype(k+1,1))
8301         itj=itortyp(itype(j,1))
8302         if (l.lt.nres-1) then
8303           itl1=itortyp(itype(l+1,1))
8304         else
8305           itl1=ntortyp+1
8306         endif
8307 ! A1 kernel(j+1) A2T
8308 !d        do iii=1,2
8309 !d          write (iout,'(3f10.5,5x,3f10.5)')
8310 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8311 !d        enddo
8312         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8313          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8314          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8315 ! Following matrices are needed only for 6-th order cumulants
8316         IF (wcorr6.gt.0.0d0) THEN
8317         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8318          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8319          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8320         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8321          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8322          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8323          ADtEAderx(1,1,1,1,1,1))
8324         lprn=.false.
8325         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8326          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8327          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8328          ADtEA1derx(1,1,1,1,1,1))
8329         ENDIF
8330 ! End 6-th order cumulants
8331 !d        lprn=.false.
8332 !d        if (lprn) then
8333 !d        write (2,*) 'In calc_eello6'
8334 !d        do iii=1,2
8335 !d          write (2,*) 'iii=',iii
8336 !d          do kkk=1,5
8337 !d            write (2,*) 'kkk=',kkk
8338 !d            do jjj=1,2
8339 !d              write (2,'(3(2f10.5),5x)')
8340 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8341 !d            enddo
8342 !d          enddo
8343 !d        enddo
8344 !d        endif
8345         call transpose2(EUgder(1,1,k),auxmat(1,1))
8346         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8347         call transpose2(EUg(1,1,k),auxmat(1,1))
8348         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8349         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8350         do iii=1,2
8351           do kkk=1,5
8352             do lll=1,3
8353               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8354                 EAEAderx(1,1,lll,kkk,iii,1))
8355             enddo
8356           enddo
8357         enddo
8358 ! A1T kernel(i+1) A2
8359         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8360          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8361          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8362 ! Following matrices are needed only for 6-th order cumulants
8363         IF (wcorr6.gt.0.0d0) THEN
8364         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8365          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8366          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8367         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8368          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8369          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8370          ADtEAderx(1,1,1,1,1,2))
8371         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8372          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8373          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8374          ADtEA1derx(1,1,1,1,1,2))
8375         ENDIF
8376 ! End 6-th order cumulants
8377         call transpose2(EUgder(1,1,l),auxmat(1,1))
8378         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8379         call transpose2(EUg(1,1,l),auxmat(1,1))
8380         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8381         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8382         do iii=1,2
8383           do kkk=1,5
8384             do lll=1,3
8385               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8386                 EAEAderx(1,1,lll,kkk,iii,2))
8387             enddo
8388           enddo
8389         enddo
8390 ! AEAb1 and AEAb2
8391 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8392 ! They are needed only when the fifth- or the sixth-order cumulants are
8393 ! indluded.
8394         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8395         call transpose2(AEA(1,1,1),auxmat(1,1))
8396         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8397         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8398         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8399         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8400         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8401         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8402         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8403         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8404         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8405         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8406         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8407         call transpose2(AEA(1,1,2),auxmat(1,1))
8408         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8409         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8410         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8411         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8412         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8413         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8414         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8415         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8416         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8417         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8418         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8419 ! Calculate the Cartesian derivatives of the vectors.
8420         do iii=1,2
8421           do kkk=1,5
8422             do lll=1,3
8423               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8424               call matvec2(auxmat(1,1),b1(1,iti),&
8425                 AEAb1derx(1,lll,kkk,iii,1,1))
8426               call matvec2(auxmat(1,1),Ub2(1,i),&
8427                 AEAb2derx(1,lll,kkk,iii,1,1))
8428               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8429                 AEAb1derx(1,lll,kkk,iii,2,1))
8430               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8431                 AEAb2derx(1,lll,kkk,iii,2,1))
8432               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8433               call matvec2(auxmat(1,1),b1(1,itj),&
8434                 AEAb1derx(1,lll,kkk,iii,1,2))
8435               call matvec2(auxmat(1,1),Ub2(1,j),&
8436                 AEAb2derx(1,lll,kkk,iii,1,2))
8437               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8438                 AEAb1derx(1,lll,kkk,iii,2,2))
8439               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8440                 AEAb2derx(1,lll,kkk,iii,2,2))
8441             enddo
8442           enddo
8443         enddo
8444         ENDIF
8445 ! End vectors
8446       else
8447 ! Antiparallel orientation of the two CA-CA-CA frames.
8448         if (i.gt.1) then
8449           iti=itortyp(itype(i,1))
8450         else
8451           iti=ntortyp+1
8452         endif
8453         itk1=itortyp(itype(k+1,1))
8454         itl=itortyp(itype(l,1))
8455         itj=itortyp(itype(j,1))
8456         if (j.lt.nres-1) then
8457           itj1=itortyp(itype(j+1,1))
8458         else
8459           itj1=ntortyp+1
8460         endif
8461 ! A2 kernel(j-1)T A1T
8462         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8463          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8464          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8465 ! Following matrices are needed only for 6-th order cumulants
8466         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8467            j.eq.i+4 .and. l.eq.i+3)) THEN
8468         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8469          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8470          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8471         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8472          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8473          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8474          ADtEAderx(1,1,1,1,1,1))
8475         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8476          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8477          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8478          ADtEA1derx(1,1,1,1,1,1))
8479         ENDIF
8480 ! End 6-th order cumulants
8481         call transpose2(EUgder(1,1,k),auxmat(1,1))
8482         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8483         call transpose2(EUg(1,1,k),auxmat(1,1))
8484         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8485         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8486         do iii=1,2
8487           do kkk=1,5
8488             do lll=1,3
8489               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8490                 EAEAderx(1,1,lll,kkk,iii,1))
8491             enddo
8492           enddo
8493         enddo
8494 ! A2T kernel(i+1)T A1
8495         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8496          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8497          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8498 ! Following matrices are needed only for 6-th order cumulants
8499         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8500            j.eq.i+4 .and. l.eq.i+3)) THEN
8501         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8502          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8503          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8504         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8505          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8506          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8507          ADtEAderx(1,1,1,1,1,2))
8508         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8509          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8510          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8511          ADtEA1derx(1,1,1,1,1,2))
8512         ENDIF
8513 ! End 6-th order cumulants
8514         call transpose2(EUgder(1,1,j),auxmat(1,1))
8515         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8516         call transpose2(EUg(1,1,j),auxmat(1,1))
8517         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8518         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8519         do iii=1,2
8520           do kkk=1,5
8521             do lll=1,3
8522               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8523                 EAEAderx(1,1,lll,kkk,iii,2))
8524             enddo
8525           enddo
8526         enddo
8527 ! AEAb1 and AEAb2
8528 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8529 ! They are needed only when the fifth- or the sixth-order cumulants are
8530 ! indluded.
8531         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8532           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8533         call transpose2(AEA(1,1,1),auxmat(1,1))
8534         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8535         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8536         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8537         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8538         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8539         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8540         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8541         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8542         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8543         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8544         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8545         call transpose2(AEA(1,1,2),auxmat(1,1))
8546         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8547         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8548         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8549         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8550         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8551         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8552         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8553         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8554         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8555         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8556         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8557 ! Calculate the Cartesian derivatives of the vectors.
8558         do iii=1,2
8559           do kkk=1,5
8560             do lll=1,3
8561               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8562               call matvec2(auxmat(1,1),b1(1,iti),&
8563                 AEAb1derx(1,lll,kkk,iii,1,1))
8564               call matvec2(auxmat(1,1),Ub2(1,i),&
8565                 AEAb2derx(1,lll,kkk,iii,1,1))
8566               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8567                 AEAb1derx(1,lll,kkk,iii,2,1))
8568               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8569                 AEAb2derx(1,lll,kkk,iii,2,1))
8570               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8571               call matvec2(auxmat(1,1),b1(1,itl),&
8572                 AEAb1derx(1,lll,kkk,iii,1,2))
8573               call matvec2(auxmat(1,1),Ub2(1,l),&
8574                 AEAb2derx(1,lll,kkk,iii,1,2))
8575               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8576                 AEAb1derx(1,lll,kkk,iii,2,2))
8577               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8578                 AEAb2derx(1,lll,kkk,iii,2,2))
8579             enddo
8580           enddo
8581         enddo
8582         ENDIF
8583 ! End vectors
8584       endif
8585       return
8586       end subroutine calc_eello
8587 !-----------------------------------------------------------------------------
8588       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8589       use comm_kut
8590       implicit none
8591       integer :: nderg
8592       logical :: transp
8593       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8594       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8595       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8596       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8597       integer :: iii,kkk,lll
8598       integer :: jjj,mmm
8599 !el      logical :: lprn
8600 !el      common /kutas/ lprn
8601       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8602       do iii=1,nderg
8603         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8604           AKAderg(1,1,iii))
8605       enddo
8606 !d      if (lprn) write (2,*) 'In kernel'
8607       do kkk=1,5
8608 !d        if (lprn) write (2,*) 'kkk=',kkk
8609         do lll=1,3
8610           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8611             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8612 !d          if (lprn) then
8613 !d            write (2,*) 'lll=',lll
8614 !d            write (2,*) 'iii=1'
8615 !d            do jjj=1,2
8616 !d              write (2,'(3(2f10.5),5x)')
8617 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8618 !d            enddo
8619 !d          endif
8620           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8621             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8622 !d          if (lprn) then
8623 !d            write (2,*) 'lll=',lll
8624 !d            write (2,*) 'iii=2'
8625 !d            do jjj=1,2
8626 !d              write (2,'(3(2f10.5),5x)')
8627 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8628 !d            enddo
8629 !d          endif
8630         enddo
8631       enddo
8632       return
8633       end subroutine kernel
8634 !-----------------------------------------------------------------------------
8635       real(kind=8) function eello4(i,j,k,l,jj,kk)
8636 !      implicit real*8 (a-h,o-z)
8637 !      include 'DIMENSIONS'
8638 !      include 'COMMON.IOUNITS'
8639 !      include 'COMMON.CHAIN'
8640 !      include 'COMMON.DERIV'
8641 !      include 'COMMON.INTERACT'
8642 !      include 'COMMON.CONTACTS'
8643 !      include 'COMMON.TORSION'
8644 !      include 'COMMON.VAR'
8645 !      include 'COMMON.GEO'
8646       real(kind=8),dimension(2,2) :: pizda
8647       real(kind=8),dimension(3) :: ggg1,ggg2
8648       real(kind=8) ::  eel4,glongij,glongkl
8649       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8650 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8651 !d        eello4=0.0d0
8652 !d        return
8653 !d      endif
8654 !d      print *,'eello4:',i,j,k,l,jj,kk
8655 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8656 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8657 !old      eij=facont_hb(jj,i)
8658 !old      ekl=facont_hb(kk,k)
8659 !old      ekont=eij*ekl
8660       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8661 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8662       gcorr_loc(k-1)=gcorr_loc(k-1) &
8663          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8664       if (l.eq.j+1) then
8665         gcorr_loc(l-1)=gcorr_loc(l-1) &
8666            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8667       else
8668         gcorr_loc(j-1)=gcorr_loc(j-1) &
8669            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8670       endif
8671       do iii=1,2
8672         do kkk=1,5
8673           do lll=1,3
8674             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8675                               -EAEAderx(2,2,lll,kkk,iii,1)
8676 !d            derx(lll,kkk,iii)=0.0d0
8677           enddo
8678         enddo
8679       enddo
8680 !d      gcorr_loc(l-1)=0.0d0
8681 !d      gcorr_loc(j-1)=0.0d0
8682 !d      gcorr_loc(k-1)=0.0d0
8683 !d      eel4=1.0d0
8684 !d      write (iout,*)'Contacts have occurred for peptide groups',
8685 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8686 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8687       if (j.lt.nres-1) then
8688         j1=j+1
8689         j2=j-1
8690       else
8691         j1=j-1
8692         j2=j-2
8693       endif
8694       if (l.lt.nres-1) then
8695         l1=l+1
8696         l2=l-1
8697       else
8698         l1=l-1
8699         l2=l-2
8700       endif
8701       do ll=1,3
8702 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8703 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8704         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8705         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8706 !grad        ghalf=0.5d0*ggg1(ll)
8707         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8708         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8709         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8710         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8711         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8712         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8713 !grad        ghalf=0.5d0*ggg2(ll)
8714         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8715         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8716         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8717         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8718         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8719         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8720       enddo
8721 !grad      do m=i+1,j-1
8722 !grad        do ll=1,3
8723 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8724 !grad        enddo
8725 !grad      enddo
8726 !grad      do m=k+1,l-1
8727 !grad        do ll=1,3
8728 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8729 !grad        enddo
8730 !grad      enddo
8731 !grad      do m=i+2,j2
8732 !grad        do ll=1,3
8733 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8734 !grad        enddo
8735 !grad      enddo
8736 !grad      do m=k+2,l2
8737 !grad        do ll=1,3
8738 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8739 !grad        enddo
8740 !grad      enddo
8741 !d      do iii=1,nres-3
8742 !d        write (2,*) iii,gcorr_loc(iii)
8743 !d      enddo
8744       eello4=ekont*eel4
8745 !d      write (2,*) 'ekont',ekont
8746 !d      write (iout,*) 'eello4',ekont*eel4
8747       return
8748       end function eello4
8749 !-----------------------------------------------------------------------------
8750       real(kind=8) function eello5(i,j,k,l,jj,kk)
8751 !      implicit real*8 (a-h,o-z)
8752 !      include 'DIMENSIONS'
8753 !      include 'COMMON.IOUNITS'
8754 !      include 'COMMON.CHAIN'
8755 !      include 'COMMON.DERIV'
8756 !      include 'COMMON.INTERACT'
8757 !      include 'COMMON.CONTACTS'
8758 !      include 'COMMON.TORSION'
8759 !      include 'COMMON.VAR'
8760 !      include 'COMMON.GEO'
8761       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8762       real(kind=8),dimension(2) :: vv
8763       real(kind=8),dimension(3) :: ggg1,ggg2
8764       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8765       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8766       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8767 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8768 !                                                                              C
8769 !                            Parallel chains                                   C
8770 !                                                                              C
8771 !          o             o                   o             o                   C
8772 !         /l\           / \             \   / \           / \   /              C
8773 !        /   \         /   \             \ /   \         /   \ /               C
8774 !       j| o |l1       | o |                o| o |         | o |o                C
8775 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8776 !      \i/   \         /   \ /             /   \         /   \                 C
8777 !       o    k1             o                                                  C
8778 !         (I)          (II)                (III)          (IV)                 C
8779 !                                                                              C
8780 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8781 !                                                                              C
8782 !                            Antiparallel chains                               C
8783 !                                                                              C
8784 !          o             o                   o             o                   C
8785 !         /j\           / \             \   / \           / \   /              C
8786 !        /   \         /   \             \ /   \         /   \ /               C
8787 !      j1| o |l        | o |                o| o |         | o |o                C
8788 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8789 !      \i/   \         /   \ /             /   \         /   \                 C
8790 !       o     k1            o                                                  C
8791 !         (I)          (II)                (III)          (IV)                 C
8792 !                                                                              C
8793 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8794 !                                                                              C
8795 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8796 !                                                                              C
8797 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8798 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8799 !d        eello5=0.0d0
8800 !d        return
8801 !d      endif
8802 !d      write (iout,*)
8803 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8804 !d     &   ' and',k,l
8805       itk=itortyp(itype(k,1))
8806       itl=itortyp(itype(l,1))
8807       itj=itortyp(itype(j,1))
8808       eello5_1=0.0d0
8809       eello5_2=0.0d0
8810       eello5_3=0.0d0
8811       eello5_4=0.0d0
8812 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8813 !d     &   eel5_3_num,eel5_4_num)
8814       do iii=1,2
8815         do kkk=1,5
8816           do lll=1,3
8817             derx(lll,kkk,iii)=0.0d0
8818           enddo
8819         enddo
8820       enddo
8821 !d      eij=facont_hb(jj,i)
8822 !d      ekl=facont_hb(kk,k)
8823 !d      ekont=eij*ekl
8824 !d      write (iout,*)'Contacts have occurred for peptide groups',
8825 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8826 !d      goto 1111
8827 ! Contribution from the graph I.
8828 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8829 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8830       call transpose2(EUg(1,1,k),auxmat(1,1))
8831       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8832       vv(1)=pizda(1,1)-pizda(2,2)
8833       vv(2)=pizda(1,2)+pizda(2,1)
8834       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8835        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8836 ! Explicit gradient in virtual-dihedral angles.
8837       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8838        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8839        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8840       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8841       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8842       vv(1)=pizda(1,1)-pizda(2,2)
8843       vv(2)=pizda(1,2)+pizda(2,1)
8844       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8845        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8846        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8847       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8848       vv(1)=pizda(1,1)-pizda(2,2)
8849       vv(2)=pizda(1,2)+pizda(2,1)
8850       if (l.eq.j+1) then
8851         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8852          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8853          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8854       else
8855         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8856          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8857          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8858       endif
8859 ! Cartesian gradient
8860       do iii=1,2
8861         do kkk=1,5
8862           do lll=1,3
8863             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8864               pizda(1,1))
8865             vv(1)=pizda(1,1)-pizda(2,2)
8866             vv(2)=pizda(1,2)+pizda(2,1)
8867             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8868              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8869              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8870           enddo
8871         enddo
8872       enddo
8873 !      goto 1112
8874 !1111  continue
8875 ! Contribution from graph II
8876       call transpose2(EE(1,1,itk),auxmat(1,1))
8877       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8878       vv(1)=pizda(1,1)+pizda(2,2)
8879       vv(2)=pizda(2,1)-pizda(1,2)
8880       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8881        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8882 ! Explicit gradient in virtual-dihedral angles.
8883       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8884        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8885       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8886       vv(1)=pizda(1,1)+pizda(2,2)
8887       vv(2)=pizda(2,1)-pizda(1,2)
8888       if (l.eq.j+1) then
8889         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8890          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8891          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8892       else
8893         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8894          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8895          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8896       endif
8897 ! Cartesian gradient
8898       do iii=1,2
8899         do kkk=1,5
8900           do lll=1,3
8901             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8902               pizda(1,1))
8903             vv(1)=pizda(1,1)+pizda(2,2)
8904             vv(2)=pizda(2,1)-pizda(1,2)
8905             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8906              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8907              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8908           enddo
8909         enddo
8910       enddo
8911 !d      goto 1112
8912 !d1111  continue
8913       if (l.eq.j+1) then
8914 !d        goto 1110
8915 ! Parallel orientation
8916 ! Contribution from graph III
8917         call transpose2(EUg(1,1,l),auxmat(1,1))
8918         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8919         vv(1)=pizda(1,1)-pizda(2,2)
8920         vv(2)=pizda(1,2)+pizda(2,1)
8921         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8922          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8923 ! Explicit gradient in virtual-dihedral angles.
8924         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8925          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8926          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8927         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8928         vv(1)=pizda(1,1)-pizda(2,2)
8929         vv(2)=pizda(1,2)+pizda(2,1)
8930         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8931          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8932          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8933         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8934         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8935         vv(1)=pizda(1,1)-pizda(2,2)
8936         vv(2)=pizda(1,2)+pizda(2,1)
8937         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8938          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8939          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8940 ! Cartesian gradient
8941         do iii=1,2
8942           do kkk=1,5
8943             do lll=1,3
8944               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8945                 pizda(1,1))
8946               vv(1)=pizda(1,1)-pizda(2,2)
8947               vv(2)=pizda(1,2)+pizda(2,1)
8948               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8949                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8950                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8951             enddo
8952           enddo
8953         enddo
8954 !d        goto 1112
8955 ! Contribution from graph IV
8956 !d1110    continue
8957         call transpose2(EE(1,1,itl),auxmat(1,1))
8958         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8959         vv(1)=pizda(1,1)+pizda(2,2)
8960         vv(2)=pizda(2,1)-pizda(1,2)
8961         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8962          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8963 ! Explicit gradient in virtual-dihedral angles.
8964         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8965          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8966         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8967         vv(1)=pizda(1,1)+pizda(2,2)
8968         vv(2)=pizda(2,1)-pizda(1,2)
8969         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8970          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8971          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8972 ! Cartesian gradient
8973         do iii=1,2
8974           do kkk=1,5
8975             do lll=1,3
8976               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8977                 pizda(1,1))
8978               vv(1)=pizda(1,1)+pizda(2,2)
8979               vv(2)=pizda(2,1)-pizda(1,2)
8980               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8981                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8982                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8983             enddo
8984           enddo
8985         enddo
8986       else
8987 ! Antiparallel orientation
8988 ! Contribution from graph III
8989 !        goto 1110
8990         call transpose2(EUg(1,1,j),auxmat(1,1))
8991         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8992         vv(1)=pizda(1,1)-pizda(2,2)
8993         vv(2)=pizda(1,2)+pizda(2,1)
8994         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8995          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8996 ! Explicit gradient in virtual-dihedral angles.
8997         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8998          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8999          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9000         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9001         vv(1)=pizda(1,1)-pizda(2,2)
9002         vv(2)=pizda(1,2)+pizda(2,1)
9003         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9004          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9005          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9006         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9007         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9008         vv(1)=pizda(1,1)-pizda(2,2)
9009         vv(2)=pizda(1,2)+pizda(2,1)
9010         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9011          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9012          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9013 ! Cartesian gradient
9014         do iii=1,2
9015           do kkk=1,5
9016             do lll=1,3
9017               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9018                 pizda(1,1))
9019               vv(1)=pizda(1,1)-pizda(2,2)
9020               vv(2)=pizda(1,2)+pizda(2,1)
9021               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9022                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9023                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9024             enddo
9025           enddo
9026         enddo
9027 !d        goto 1112
9028 ! Contribution from graph IV
9029 1110    continue
9030         call transpose2(EE(1,1,itj),auxmat(1,1))
9031         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9032         vv(1)=pizda(1,1)+pizda(2,2)
9033         vv(2)=pizda(2,1)-pizda(1,2)
9034         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9035          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9036 ! Explicit gradient in virtual-dihedral angles.
9037         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9038          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9039         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9040         vv(1)=pizda(1,1)+pizda(2,2)
9041         vv(2)=pizda(2,1)-pizda(1,2)
9042         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9043          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9044          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9045 ! Cartesian gradient
9046         do iii=1,2
9047           do kkk=1,5
9048             do lll=1,3
9049               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9050                 pizda(1,1))
9051               vv(1)=pizda(1,1)+pizda(2,2)
9052               vv(2)=pizda(2,1)-pizda(1,2)
9053               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9054                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9055                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9056             enddo
9057           enddo
9058         enddo
9059       endif
9060 1112  continue
9061       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9062 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9063 !d        write (2,*) 'ijkl',i,j,k,l
9064 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9065 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9066 !d      endif
9067 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9068 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9069 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9070 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9071       if (j.lt.nres-1) then
9072         j1=j+1
9073         j2=j-1
9074       else
9075         j1=j-1
9076         j2=j-2
9077       endif
9078       if (l.lt.nres-1) then
9079         l1=l+1
9080         l2=l-1
9081       else
9082         l1=l-1
9083         l2=l-2
9084       endif
9085 !d      eij=1.0d0
9086 !d      ekl=1.0d0
9087 !d      ekont=1.0d0
9088 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9089 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9090 !        summed up outside the subrouine as for the other subroutines
9091 !        handling long-range interactions. The old code is commented out
9092 !        with "cgrad" to keep track of changes.
9093       do ll=1,3
9094 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9095 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9096         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9097         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9098 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9099 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9100 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9101 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9102 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9103 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9104 !     &   gradcorr5ij,
9105 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9106 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9107 !grad        ghalf=0.5d0*ggg1(ll)
9108 !d        ghalf=0.0d0
9109         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9110         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9111         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9112         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9113         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9114         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9115 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9116 !grad        ghalf=0.5d0*ggg2(ll)
9117         ghalf=0.0d0
9118         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9119         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9120         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9121         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9122         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9123         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9124       enddo
9125 !d      goto 1112
9126 !grad      do m=i+1,j-1
9127 !grad        do ll=1,3
9128 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9129 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9130 !grad        enddo
9131 !grad      enddo
9132 !grad      do m=k+1,l-1
9133 !grad        do ll=1,3
9134 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9135 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9136 !grad        enddo
9137 !grad      enddo
9138 !1112  continue
9139 !grad      do m=i+2,j2
9140 !grad        do ll=1,3
9141 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9142 !grad        enddo
9143 !grad      enddo
9144 !grad      do m=k+2,l2
9145 !grad        do ll=1,3
9146 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9147 !grad        enddo
9148 !grad      enddo
9149 !d      do iii=1,nres-3
9150 !d        write (2,*) iii,g_corr5_loc(iii)
9151 !d      enddo
9152       eello5=ekont*eel5
9153 !d      write (2,*) 'ekont',ekont
9154 !d      write (iout,*) 'eello5',ekont*eel5
9155       return
9156       end function eello5
9157 !-----------------------------------------------------------------------------
9158       real(kind=8) function eello6(i,j,k,l,jj,kk)
9159 !      implicit real*8 (a-h,o-z)
9160 !      include 'DIMENSIONS'
9161 !      include 'COMMON.IOUNITS'
9162 !      include 'COMMON.CHAIN'
9163 !      include 'COMMON.DERIV'
9164 !      include 'COMMON.INTERACT'
9165 !      include 'COMMON.CONTACTS'
9166 !      include 'COMMON.TORSION'
9167 !      include 'COMMON.VAR'
9168 !      include 'COMMON.GEO'
9169 !      include 'COMMON.FFIELD'
9170       real(kind=8),dimension(3) :: ggg1,ggg2
9171       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9172                    eello6_6,eel6
9173       real(kind=8) :: gradcorr6ij,gradcorr6kl
9174       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9175 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9176 !d        eello6=0.0d0
9177 !d        return
9178 !d      endif
9179 !d      write (iout,*)
9180 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9181 !d     &   ' and',k,l
9182       eello6_1=0.0d0
9183       eello6_2=0.0d0
9184       eello6_3=0.0d0
9185       eello6_4=0.0d0
9186       eello6_5=0.0d0
9187       eello6_6=0.0d0
9188 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9189 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9190       do iii=1,2
9191         do kkk=1,5
9192           do lll=1,3
9193             derx(lll,kkk,iii)=0.0d0
9194           enddo
9195         enddo
9196       enddo
9197 !d      eij=facont_hb(jj,i)
9198 !d      ekl=facont_hb(kk,k)
9199 !d      ekont=eij*ekl
9200 !d      eij=1.0d0
9201 !d      ekl=1.0d0
9202 !d      ekont=1.0d0
9203       if (l.eq.j+1) then
9204         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9205         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9206         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9207         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9208         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9209         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9210       else
9211         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9212         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9213         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9214         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9215         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9216           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9217         else
9218           eello6_5=0.0d0
9219         endif
9220         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9221       endif
9222 ! If turn contributions are considered, they will be handled separately.
9223       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9224 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9225 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9226 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9227 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9228 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9229 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9230 !d      goto 1112
9231       if (j.lt.nres-1) then
9232         j1=j+1
9233         j2=j-1
9234       else
9235         j1=j-1
9236         j2=j-2
9237       endif
9238       if (l.lt.nres-1) then
9239         l1=l+1
9240         l2=l-1
9241       else
9242         l1=l-1
9243         l2=l-2
9244       endif
9245       do ll=1,3
9246 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9247 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9248 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9249 !grad        ghalf=0.5d0*ggg1(ll)
9250 !d        ghalf=0.0d0
9251         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9252         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9253         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9254         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9255         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9256         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9257         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9258         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9259 !grad        ghalf=0.5d0*ggg2(ll)
9260 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9261 !d        ghalf=0.0d0
9262         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9263         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9264         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9265         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9266         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9267         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9268       enddo
9269 !d      goto 1112
9270 !grad      do m=i+1,j-1
9271 !grad        do ll=1,3
9272 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9273 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9274 !grad        enddo
9275 !grad      enddo
9276 !grad      do m=k+1,l-1
9277 !grad        do ll=1,3
9278 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9279 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9280 !grad        enddo
9281 !grad      enddo
9282 !grad1112  continue
9283 !grad      do m=i+2,j2
9284 !grad        do ll=1,3
9285 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9286 !grad        enddo
9287 !grad      enddo
9288 !grad      do m=k+2,l2
9289 !grad        do ll=1,3
9290 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9291 !grad        enddo
9292 !grad      enddo
9293 !d      do iii=1,nres-3
9294 !d        write (2,*) iii,g_corr6_loc(iii)
9295 !d      enddo
9296       eello6=ekont*eel6
9297 !d      write (2,*) 'ekont',ekont
9298 !d      write (iout,*) 'eello6',ekont*eel6
9299       return
9300       end function eello6
9301 !-----------------------------------------------------------------------------
9302       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9303       use comm_kut
9304 !      implicit real*8 (a-h,o-z)
9305 !      include 'DIMENSIONS'
9306 !      include 'COMMON.IOUNITS'
9307 !      include 'COMMON.CHAIN'
9308 !      include 'COMMON.DERIV'
9309 !      include 'COMMON.INTERACT'
9310 !      include 'COMMON.CONTACTS'
9311 !      include 'COMMON.TORSION'
9312 !      include 'COMMON.VAR'
9313 !      include 'COMMON.GEO'
9314       real(kind=8),dimension(2) :: vv,vv1
9315       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9316       logical :: swap
9317 !el      logical :: lprn
9318 !el      common /kutas/ lprn
9319       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9320       real(kind=8) :: s1,s2,s3,s4,s5
9321 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9322 !                                                                              C
9323 !      Parallel       Antiparallel                                             C
9324 !                                                                              C
9325 !          o             o                                                     C
9326 !         /l\           /j\                                                    C
9327 !        /   \         /   \                                                   C
9328 !       /| o |         | o |\                                                  C
9329 !     \ j|/k\|  /   \  |/k\|l /                                                C
9330 !      \ /   \ /     \ /   \ /                                                 C
9331 !       o     o       o     o                                                  C
9332 !       i             i                                                        C
9333 !                                                                              C
9334 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9335       itk=itortyp(itype(k,1))
9336       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9337       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9338       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9339       call transpose2(EUgC(1,1,k),auxmat(1,1))
9340       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9341       vv1(1)=pizda1(1,1)-pizda1(2,2)
9342       vv1(2)=pizda1(1,2)+pizda1(2,1)
9343       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9344       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9345       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9346       s5=scalar2(vv(1),Dtobr2(1,i))
9347 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9348       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9349       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9350        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9351        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9352        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9353        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9354        +scalar2(vv(1),Dtobr2der(1,i)))
9355       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9356       vv1(1)=pizda1(1,1)-pizda1(2,2)
9357       vv1(2)=pizda1(1,2)+pizda1(2,1)
9358       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9359       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9360       if (l.eq.j+1) then
9361         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9362        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9363        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9364        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9365        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9366       else
9367         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9368        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9369        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9370        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9371        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9372       endif
9373       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9374       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9375       vv1(1)=pizda1(1,1)-pizda1(2,2)
9376       vv1(2)=pizda1(1,2)+pizda1(2,1)
9377       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9378        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9379        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9380        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9381       do iii=1,2
9382         if (swap) then
9383           ind=3-iii
9384         else
9385           ind=iii
9386         endif
9387         do kkk=1,5
9388           do lll=1,3
9389             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9390             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9391             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9392             call transpose2(EUgC(1,1,k),auxmat(1,1))
9393             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9394               pizda1(1,1))
9395             vv1(1)=pizda1(1,1)-pizda1(2,2)
9396             vv1(2)=pizda1(1,2)+pizda1(2,1)
9397             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9398             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9399              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9400             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9401              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9402             s5=scalar2(vv(1),Dtobr2(1,i))
9403             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9404           enddo
9405         enddo
9406       enddo
9407       return
9408       end function eello6_graph1
9409 !-----------------------------------------------------------------------------
9410       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9411       use comm_kut
9412 !      implicit real*8 (a-h,o-z)
9413 !      include 'DIMENSIONS'
9414 !      include 'COMMON.IOUNITS'
9415 !      include 'COMMON.CHAIN'
9416 !      include 'COMMON.DERIV'
9417 !      include 'COMMON.INTERACT'
9418 !      include 'COMMON.CONTACTS'
9419 !      include 'COMMON.TORSION'
9420 !      include 'COMMON.VAR'
9421 !      include 'COMMON.GEO'
9422       logical :: swap
9423       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9424       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9425 !el      logical :: lprn
9426 !el      common /kutas/ lprn
9427       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9428       real(kind=8) :: s2,s3,s4
9429 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9430 !                                                                              C
9431 !      Parallel       Antiparallel                                             C
9432 !                                                                              C
9433 !          o             o                                                     C
9434 !     \   /l\           /j\   /                                                C
9435 !      \ /   \         /   \ /                                                 C
9436 !       o| o |         | o |o                                                  C
9437 !     \ j|/k\|      \  |/k\|l                                                  C
9438 !      \ /   \       \ /   \                                                   C
9439 !       o             o                                                        C
9440 !       i             i                                                        C
9441 !                                                                              C
9442 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9443 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9444 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9445 !           but not in a cluster cumulant
9446 #ifdef MOMENT
9447       s1=dip(1,jj,i)*dip(1,kk,k)
9448 #endif
9449       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9450       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9451       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9452       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9453       call transpose2(EUg(1,1,k),auxmat(1,1))
9454       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9455       vv(1)=pizda(1,1)-pizda(2,2)
9456       vv(2)=pizda(1,2)+pizda(2,1)
9457       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9458 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9459 #ifdef MOMENT
9460       eello6_graph2=-(s1+s2+s3+s4)
9461 #else
9462       eello6_graph2=-(s2+s3+s4)
9463 #endif
9464 !      eello6_graph2=-s3
9465 ! Derivatives in gamma(i-1)
9466       if (i.gt.1) then
9467 #ifdef MOMENT
9468         s1=dipderg(1,jj,i)*dip(1,kk,k)
9469 #endif
9470         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9471         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9472         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9473         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9474 #ifdef MOMENT
9475         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9476 #else
9477         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9478 #endif
9479 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9480       endif
9481 ! Derivatives in gamma(k-1)
9482 #ifdef MOMENT
9483       s1=dip(1,jj,i)*dipderg(1,kk,k)
9484 #endif
9485       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9486       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9487       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9488       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9489       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9490       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9491       vv(1)=pizda(1,1)-pizda(2,2)
9492       vv(2)=pizda(1,2)+pizda(2,1)
9493       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9494 #ifdef MOMENT
9495       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9496 #else
9497       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9498 #endif
9499 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9500 ! Derivatives in gamma(j-1) or gamma(l-1)
9501       if (j.gt.1) then
9502 #ifdef MOMENT
9503         s1=dipderg(3,jj,i)*dip(1,kk,k)
9504 #endif
9505         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9506         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9507         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9508         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9509         vv(1)=pizda(1,1)-pizda(2,2)
9510         vv(2)=pizda(1,2)+pizda(2,1)
9511         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9512 #ifdef MOMENT
9513         if (swap) then
9514           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9515         else
9516           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9517         endif
9518 #endif
9519         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9520 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9521       endif
9522 ! Derivatives in gamma(l-1) or gamma(j-1)
9523       if (l.gt.1) then
9524 #ifdef MOMENT
9525         s1=dip(1,jj,i)*dipderg(3,kk,k)
9526 #endif
9527         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9528         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9529         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9530         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9531         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9532         vv(1)=pizda(1,1)-pizda(2,2)
9533         vv(2)=pizda(1,2)+pizda(2,1)
9534         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9535 #ifdef MOMENT
9536         if (swap) then
9537           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9538         else
9539           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9540         endif
9541 #endif
9542         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9543 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9544       endif
9545 ! Cartesian derivatives.
9546       if (lprn) then
9547         write (2,*) 'In eello6_graph2'
9548         do iii=1,2
9549           write (2,*) 'iii=',iii
9550           do kkk=1,5
9551             write (2,*) 'kkk=',kkk
9552             do jjj=1,2
9553               write (2,'(3(2f10.5),5x)') &
9554               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9555             enddo
9556           enddo
9557         enddo
9558       endif
9559       do iii=1,2
9560         do kkk=1,5
9561           do lll=1,3
9562 #ifdef MOMENT
9563             if (iii.eq.1) then
9564               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9565             else
9566               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9567             endif
9568 #endif
9569             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9570               auxvec(1))
9571             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9572             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9573               auxvec(1))
9574             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9575             call transpose2(EUg(1,1,k),auxmat(1,1))
9576             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9577               pizda(1,1))
9578             vv(1)=pizda(1,1)-pizda(2,2)
9579             vv(2)=pizda(1,2)+pizda(2,1)
9580             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9581 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9582 #ifdef MOMENT
9583             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9584 #else
9585             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9586 #endif
9587             if (swap) then
9588               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9589             else
9590               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9591             endif
9592           enddo
9593         enddo
9594       enddo
9595       return
9596       end function eello6_graph2
9597 !-----------------------------------------------------------------------------
9598       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9599 !      implicit real*8 (a-h,o-z)
9600 !      include 'DIMENSIONS'
9601 !      include 'COMMON.IOUNITS'
9602 !      include 'COMMON.CHAIN'
9603 !      include 'COMMON.DERIV'
9604 !      include 'COMMON.INTERACT'
9605 !      include 'COMMON.CONTACTS'
9606 !      include 'COMMON.TORSION'
9607 !      include 'COMMON.VAR'
9608 !      include 'COMMON.GEO'
9609       real(kind=8),dimension(2) :: vv,auxvec
9610       real(kind=8),dimension(2,2) :: pizda,auxmat
9611       logical :: swap
9612       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9613       real(kind=8) :: s1,s2,s3,s4
9614 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9615 !                                                                              C
9616 !      Parallel       Antiparallel                                             C
9617 !                                                                              C
9618 !          o             o                                                     C
9619 !         /l\   /   \   /j\                                                    C
9620 !        /   \ /     \ /   \                                                   C
9621 !       /| o |o       o| o |\                                                  C
9622 !       j|/k\|  /      |/k\|l /                                                C
9623 !        /   \ /       /   \ /                                                 C
9624 !       /     o       /     o                                                  C
9625 !       i             i                                                        C
9626 !                                                                              C
9627 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9628 !
9629 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9630 !           energy moment and not to the cluster cumulant.
9631       iti=itortyp(itype(i,1))
9632       if (j.lt.nres-1) then
9633         itj1=itortyp(itype(j+1,1))
9634       else
9635         itj1=ntortyp+1
9636       endif
9637       itk=itortyp(itype(k,1))
9638       itk1=itortyp(itype(k+1,1))
9639       if (l.lt.nres-1) then
9640         itl1=itortyp(itype(l+1,1))
9641       else
9642         itl1=ntortyp+1
9643       endif
9644 #ifdef MOMENT
9645       s1=dip(4,jj,i)*dip(4,kk,k)
9646 #endif
9647       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9648       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9649       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9650       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9651       call transpose2(EE(1,1,itk),auxmat(1,1))
9652       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9653       vv(1)=pizda(1,1)+pizda(2,2)
9654       vv(2)=pizda(2,1)-pizda(1,2)
9655       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9656 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9657 !d     & "sum",-(s2+s3+s4)
9658 #ifdef MOMENT
9659       eello6_graph3=-(s1+s2+s3+s4)
9660 #else
9661       eello6_graph3=-(s2+s3+s4)
9662 #endif
9663 !      eello6_graph3=-s4
9664 ! Derivatives in gamma(k-1)
9665       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9666       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9667       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9668       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9669 ! Derivatives in gamma(l-1)
9670       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9671       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9672       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9673       vv(1)=pizda(1,1)+pizda(2,2)
9674       vv(2)=pizda(2,1)-pizda(1,2)
9675       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9676       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9677 ! Cartesian derivatives.
9678       do iii=1,2
9679         do kkk=1,5
9680           do lll=1,3
9681 #ifdef MOMENT
9682             if (iii.eq.1) then
9683               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9684             else
9685               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9686             endif
9687 #endif
9688             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9689               auxvec(1))
9690             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9691             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9692               auxvec(1))
9693             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9694             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9695               pizda(1,1))
9696             vv(1)=pizda(1,1)+pizda(2,2)
9697             vv(2)=pizda(2,1)-pizda(1,2)
9698             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9699 #ifdef MOMENT
9700             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9701 #else
9702             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9703 #endif
9704             if (swap) then
9705               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9706             else
9707               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9708             endif
9709 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9710           enddo
9711         enddo
9712       enddo
9713       return
9714       end function eello6_graph3
9715 !-----------------------------------------------------------------------------
9716       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9717 !      implicit real*8 (a-h,o-z)
9718 !      include 'DIMENSIONS'
9719 !      include 'COMMON.IOUNITS'
9720 !      include 'COMMON.CHAIN'
9721 !      include 'COMMON.DERIV'
9722 !      include 'COMMON.INTERACT'
9723 !      include 'COMMON.CONTACTS'
9724 !      include 'COMMON.TORSION'
9725 !      include 'COMMON.VAR'
9726 !      include 'COMMON.GEO'
9727 !      include 'COMMON.FFIELD'
9728       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9729       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9730       logical :: swap
9731       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9732               iii,kkk,lll
9733       real(kind=8) :: s1,s2,s3,s4
9734 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9735 !                                                                              C
9736 !      Parallel       Antiparallel                                             C
9737 !                                                                              C
9738 !          o             o                                                     C
9739 !         /l\   /   \   /j\                                                    C
9740 !        /   \ /     \ /   \                                                   C
9741 !       /| o |o       o| o |\                                                  C
9742 !     \ j|/k\|      \  |/k\|l                                                  C
9743 !      \ /   \       \ /   \                                                   C
9744 !       o     \       o     \                                                  C
9745 !       i             i                                                        C
9746 !                                                                              C
9747 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9748 !
9749 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9750 !           energy moment and not to the cluster cumulant.
9751 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9752       iti=itortyp(itype(i,1))
9753       itj=itortyp(itype(j,1))
9754       if (j.lt.nres-1) then
9755         itj1=itortyp(itype(j+1,1))
9756       else
9757         itj1=ntortyp+1
9758       endif
9759       itk=itortyp(itype(k,1))
9760       if (k.lt.nres-1) then
9761         itk1=itortyp(itype(k+1,1))
9762       else
9763         itk1=ntortyp+1
9764       endif
9765       itl=itortyp(itype(l,1))
9766       if (l.lt.nres-1) then
9767         itl1=itortyp(itype(l+1,1))
9768       else
9769         itl1=ntortyp+1
9770       endif
9771 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9772 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9773 !d     & ' itl',itl,' itl1',itl1
9774 #ifdef MOMENT
9775       if (imat.eq.1) then
9776         s1=dip(3,jj,i)*dip(3,kk,k)
9777       else
9778         s1=dip(2,jj,j)*dip(2,kk,l)
9779       endif
9780 #endif
9781       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9782       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9783       if (j.eq.l+1) then
9784         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9785         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9786       else
9787         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9788         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9789       endif
9790       call transpose2(EUg(1,1,k),auxmat(1,1))
9791       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9792       vv(1)=pizda(1,1)-pizda(2,2)
9793       vv(2)=pizda(2,1)+pizda(1,2)
9794       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9795 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9796 #ifdef MOMENT
9797       eello6_graph4=-(s1+s2+s3+s4)
9798 #else
9799       eello6_graph4=-(s2+s3+s4)
9800 #endif
9801 ! Derivatives in gamma(i-1)
9802       if (i.gt.1) then
9803 #ifdef MOMENT
9804         if (imat.eq.1) then
9805           s1=dipderg(2,jj,i)*dip(3,kk,k)
9806         else
9807           s1=dipderg(4,jj,j)*dip(2,kk,l)
9808         endif
9809 #endif
9810         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9811         if (j.eq.l+1) then
9812           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9813           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9814         else
9815           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9816           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9817         endif
9818         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9819         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9820 !d          write (2,*) 'turn6 derivatives'
9821 #ifdef MOMENT
9822           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9823 #else
9824           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9825 #endif
9826         else
9827 #ifdef MOMENT
9828           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9829 #else
9830           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9831 #endif
9832         endif
9833       endif
9834 ! Derivatives in gamma(k-1)
9835 #ifdef MOMENT
9836       if (imat.eq.1) then
9837         s1=dip(3,jj,i)*dipderg(2,kk,k)
9838       else
9839         s1=dip(2,jj,j)*dipderg(4,kk,l)
9840       endif
9841 #endif
9842       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9843       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9844       if (j.eq.l+1) then
9845         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9846         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9847       else
9848         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9849         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9850       endif
9851       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9852       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9853       vv(1)=pizda(1,1)-pizda(2,2)
9854       vv(2)=pizda(2,1)+pizda(1,2)
9855       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9856       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9857 #ifdef MOMENT
9858         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9859 #else
9860         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9861 #endif
9862       else
9863 #ifdef MOMENT
9864         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9865 #else
9866         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9867 #endif
9868       endif
9869 ! Derivatives in gamma(j-1) or gamma(l-1)
9870       if (l.eq.j+1 .and. l.gt.1) then
9871         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9872         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9873         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9874         vv(1)=pizda(1,1)-pizda(2,2)
9875         vv(2)=pizda(2,1)+pizda(1,2)
9876         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9877         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9878       else if (j.gt.1) then
9879         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9880         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9881         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9882         vv(1)=pizda(1,1)-pizda(2,2)
9883         vv(2)=pizda(2,1)+pizda(1,2)
9884         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9885         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9886           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9887         else
9888           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9889         endif
9890       endif
9891 ! Cartesian derivatives.
9892       do iii=1,2
9893         do kkk=1,5
9894           do lll=1,3
9895 #ifdef MOMENT
9896             if (iii.eq.1) then
9897               if (imat.eq.1) then
9898                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9899               else
9900                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9901               endif
9902             else
9903               if (imat.eq.1) then
9904                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9905               else
9906                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9907               endif
9908             endif
9909 #endif
9910             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9911               auxvec(1))
9912             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9913             if (j.eq.l+1) then
9914               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9915                 b1(1,itj1),auxvec(1))
9916               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9917             else
9918               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9919                 b1(1,itl1),auxvec(1))
9920               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9921             endif
9922             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9923               pizda(1,1))
9924             vv(1)=pizda(1,1)-pizda(2,2)
9925             vv(2)=pizda(2,1)+pizda(1,2)
9926             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9927             if (swap) then
9928               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9929 #ifdef MOMENT
9930                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9931                    -(s1+s2+s4)
9932 #else
9933                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9934                    -(s2+s4)
9935 #endif
9936                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9937               else
9938 #ifdef MOMENT
9939                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9940 #else
9941                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9942 #endif
9943                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9944               endif
9945             else
9946 #ifdef MOMENT
9947               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9948 #else
9949               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9950 #endif
9951               if (l.eq.j+1) then
9952                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9953               else
9954                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9955               endif
9956             endif
9957           enddo
9958         enddo
9959       enddo
9960       return
9961       end function eello6_graph4
9962 !-----------------------------------------------------------------------------
9963       real(kind=8) function eello_turn6(i,jj,kk)
9964 !      implicit real*8 (a-h,o-z)
9965 !      include 'DIMENSIONS'
9966 !      include 'COMMON.IOUNITS'
9967 !      include 'COMMON.CHAIN'
9968 !      include 'COMMON.DERIV'
9969 !      include 'COMMON.INTERACT'
9970 !      include 'COMMON.CONTACTS'
9971 !      include 'COMMON.TORSION'
9972 !      include 'COMMON.VAR'
9973 !      include 'COMMON.GEO'
9974       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9975       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9976       real(kind=8),dimension(3) :: ggg1,ggg2
9977       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9978       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9979 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9980 !           the respective energy moment and not to the cluster cumulant.
9981 !el local variables
9982       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9983       integer :: j1,j2,l1,l2,ll
9984       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9985       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9986       s1=0.0d0
9987       s8=0.0d0
9988       s13=0.0d0
9989 !
9990       eello_turn6=0.0d0
9991       j=i+4
9992       k=i+1
9993       l=i+3
9994       iti=itortyp(itype(i,1))
9995       itk=itortyp(itype(k,1))
9996       itk1=itortyp(itype(k+1,1))
9997       itl=itortyp(itype(l,1))
9998       itj=itortyp(itype(j,1))
9999 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10000 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10001 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10002 !d        eello6=0.0d0
10003 !d        return
10004 !d      endif
10005 !d      write (iout,*)
10006 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10007 !d     &   ' and',k,l
10008 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10009       do iii=1,2
10010         do kkk=1,5
10011           do lll=1,3
10012             derx_turn(lll,kkk,iii)=0.0d0
10013           enddo
10014         enddo
10015       enddo
10016 !d      eij=1.0d0
10017 !d      ekl=1.0d0
10018 !d      ekont=1.0d0
10019       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10020 !d      eello6_5=0.0d0
10021 !d      write (2,*) 'eello6_5',eello6_5
10022 #ifdef MOMENT
10023       call transpose2(AEA(1,1,1),auxmat(1,1))
10024       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10025       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10026       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10027 #endif
10028       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10029       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10030       s2 = scalar2(b1(1,itk),vtemp1(1))
10031 #ifdef MOMENT
10032       call transpose2(AEA(1,1,2),atemp(1,1))
10033       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10034       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10035       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10036 #endif
10037       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10038       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10039       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10040 #ifdef MOMENT
10041       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10042       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10043       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10044       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10045       ss13 = scalar2(b1(1,itk),vtemp4(1))
10046       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10047 #endif
10048 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10049 !      s1=0.0d0
10050 !      s2=0.0d0
10051 !      s8=0.0d0
10052 !      s12=0.0d0
10053 !      s13=0.0d0
10054       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10055 ! Derivatives in gamma(i+2)
10056       s1d =0.0d0
10057       s8d =0.0d0
10058 #ifdef MOMENT
10059       call transpose2(AEA(1,1,1),auxmatd(1,1))
10060       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10061       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10062       call transpose2(AEAderg(1,1,2),atempd(1,1))
10063       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10064       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10065 #endif
10066       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10067       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10068       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10069 !      s1d=0.0d0
10070 !      s2d=0.0d0
10071 !      s8d=0.0d0
10072 !      s12d=0.0d0
10073 !      s13d=0.0d0
10074       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10075 ! Derivatives in gamma(i+3)
10076 #ifdef MOMENT
10077       call transpose2(AEA(1,1,1),auxmatd(1,1))
10078       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10079       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10080       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10081 #endif
10082       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10083       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10084       s2d = scalar2(b1(1,itk),vtemp1d(1))
10085 #ifdef MOMENT
10086       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10087       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10088 #endif
10089       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10090 #ifdef MOMENT
10091       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10092       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10093       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10094 #endif
10095 !      s1d=0.0d0
10096 !      s2d=0.0d0
10097 !      s8d=0.0d0
10098 !      s12d=0.0d0
10099 !      s13d=0.0d0
10100 #ifdef MOMENT
10101       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10102                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10103 #else
10104       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10105                     -0.5d0*ekont*(s2d+s12d)
10106 #endif
10107 ! Derivatives in gamma(i+4)
10108       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10109       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10110       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10111 #ifdef MOMENT
10112       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10113       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10114       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10115 #endif
10116 !      s1d=0.0d0
10117 !      s2d=0.0d0
10118 !      s8d=0.0d0
10119 !      s12d=0.0d0
10120 !      s13d=0.0d0
10121 #ifdef MOMENT
10122       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10123 #else
10124       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10125 #endif
10126 ! Derivatives in gamma(i+5)
10127 #ifdef MOMENT
10128       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10129       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10130       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10131 #endif
10132       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10133       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10134       s2d = scalar2(b1(1,itk),vtemp1d(1))
10135 #ifdef MOMENT
10136       call transpose2(AEA(1,1,2),atempd(1,1))
10137       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10138       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10139 #endif
10140       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10141       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10142 #ifdef MOMENT
10143       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10144       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10145       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10146 #endif
10147 !      s1d=0.0d0
10148 !      s2d=0.0d0
10149 !      s8d=0.0d0
10150 !      s12d=0.0d0
10151 !      s13d=0.0d0
10152 #ifdef MOMENT
10153       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10154                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10155 #else
10156       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10157                     -0.5d0*ekont*(s2d+s12d)
10158 #endif
10159 ! Cartesian derivatives
10160       do iii=1,2
10161         do kkk=1,5
10162           do lll=1,3
10163 #ifdef MOMENT
10164             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10165             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10166             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10167 #endif
10168             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10169             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10170                 vtemp1d(1))
10171             s2d = scalar2(b1(1,itk),vtemp1d(1))
10172 #ifdef MOMENT
10173             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10174             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10175             s8d = -(atempd(1,1)+atempd(2,2))* &
10176                  scalar2(cc(1,1,itl),vtemp2(1))
10177 #endif
10178             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10179                  auxmatd(1,1))
10180             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10181             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10182 !      s1d=0.0d0
10183 !      s2d=0.0d0
10184 !      s8d=0.0d0
10185 !      s12d=0.0d0
10186 !      s13d=0.0d0
10187 #ifdef MOMENT
10188             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10189               - 0.5d0*(s1d+s2d)
10190 #else
10191             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10192               - 0.5d0*s2d
10193 #endif
10194 #ifdef MOMENT
10195             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10196               - 0.5d0*(s8d+s12d)
10197 #else
10198             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10199               - 0.5d0*s12d
10200 #endif
10201           enddo
10202         enddo
10203       enddo
10204 #ifdef MOMENT
10205       do kkk=1,5
10206         do lll=1,3
10207           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10208             achuj_tempd(1,1))
10209           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10210           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10211           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10212           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10213           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10214             vtemp4d(1))
10215           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10216           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10217           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10218         enddo
10219       enddo
10220 #endif
10221 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10222 !d     &  16*eel_turn6_num
10223 !d      goto 1112
10224       if (j.lt.nres-1) then
10225         j1=j+1
10226         j2=j-1
10227       else
10228         j1=j-1
10229         j2=j-2
10230       endif
10231       if (l.lt.nres-1) then
10232         l1=l+1
10233         l2=l-1
10234       else
10235         l1=l-1
10236         l2=l-2
10237       endif
10238       do ll=1,3
10239 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10240 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10241 !grad        ghalf=0.5d0*ggg1(ll)
10242 !d        ghalf=0.0d0
10243         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10244         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10245         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10246           +ekont*derx_turn(ll,2,1)
10247         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10248         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10249           +ekont*derx_turn(ll,4,1)
10250         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10251         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10252         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10253 !grad        ghalf=0.5d0*ggg2(ll)
10254 !d        ghalf=0.0d0
10255         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10256           +ekont*derx_turn(ll,2,2)
10257         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10258         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10259           +ekont*derx_turn(ll,4,2)
10260         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10261         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10262         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10263       enddo
10264 !d      goto 1112
10265 !grad      do m=i+1,j-1
10266 !grad        do ll=1,3
10267 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10268 !grad        enddo
10269 !grad      enddo
10270 !grad      do m=k+1,l-1
10271 !grad        do ll=1,3
10272 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10273 !grad        enddo
10274 !grad      enddo
10275 !grad1112  continue
10276 !grad      do m=i+2,j2
10277 !grad        do ll=1,3
10278 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10279 !grad        enddo
10280 !grad      enddo
10281 !grad      do m=k+2,l2
10282 !grad        do ll=1,3
10283 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10284 !grad        enddo
10285 !grad      enddo
10286 !d      do iii=1,nres-3
10287 !d        write (2,*) iii,g_corr6_loc(iii)
10288 !d      enddo
10289       eello_turn6=ekont*eel_turn6
10290 !d      write (2,*) 'ekont',ekont
10291 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10292       return
10293       end function eello_turn6
10294 !-----------------------------------------------------------------------------
10295       subroutine MATVEC2(A1,V1,V2)
10296 !DIR$ INLINEALWAYS MATVEC2
10297 #ifndef OSF
10298 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10299 #endif
10300 !      implicit real*8 (a-h,o-z)
10301 !      include 'DIMENSIONS'
10302       real(kind=8),dimension(2) :: V1,V2
10303       real(kind=8),dimension(2,2) :: A1
10304       real(kind=8) :: vaux1,vaux2
10305 !      DO 1 I=1,2
10306 !        VI=0.0
10307 !        DO 3 K=1,2
10308 !    3     VI=VI+A1(I,K)*V1(K)
10309 !        Vaux(I)=VI
10310 !    1 CONTINUE
10311
10312       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10313       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10314
10315       v2(1)=vaux1
10316       v2(2)=vaux2
10317       end subroutine MATVEC2
10318 !-----------------------------------------------------------------------------
10319       subroutine MATMAT2(A1,A2,A3)
10320 #ifndef OSF
10321 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10322 #endif
10323 !      implicit real*8 (a-h,o-z)
10324 !      include 'DIMENSIONS'
10325       real(kind=8),dimension(2,2) :: A1,A2,A3
10326       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10327 !      DIMENSION AI3(2,2)
10328 !        DO  J=1,2
10329 !          A3IJ=0.0
10330 !          DO K=1,2
10331 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10332 !          enddo
10333 !          A3(I,J)=A3IJ
10334 !       enddo
10335 !      enddo
10336
10337       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10338       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10339       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10340       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10341
10342       A3(1,1)=AI3_11
10343       A3(2,1)=AI3_21
10344       A3(1,2)=AI3_12
10345       A3(2,2)=AI3_22
10346       end subroutine MATMAT2
10347 !-----------------------------------------------------------------------------
10348       real(kind=8) function scalar2(u,v)
10349 !DIR$ INLINEALWAYS scalar2
10350       implicit none
10351       real(kind=8),dimension(2) :: u,v
10352       real(kind=8) :: sc
10353       integer :: i
10354       scalar2=u(1)*v(1)+u(2)*v(2)
10355       return
10356       end function scalar2
10357 !-----------------------------------------------------------------------------
10358       subroutine transpose2(a,at)
10359 !DIR$ INLINEALWAYS transpose2
10360 #ifndef OSF
10361 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10362 #endif
10363       implicit none
10364       real(kind=8),dimension(2,2) :: a,at
10365       at(1,1)=a(1,1)
10366       at(1,2)=a(2,1)
10367       at(2,1)=a(1,2)
10368       at(2,2)=a(2,2)
10369       return
10370       end subroutine transpose2
10371 !-----------------------------------------------------------------------------
10372       subroutine transpose(n,a,at)
10373       implicit none
10374       integer :: n,i,j
10375       real(kind=8),dimension(n,n) :: a,at
10376       do i=1,n
10377         do j=1,n
10378           at(j,i)=a(i,j)
10379         enddo
10380       enddo
10381       return
10382       end subroutine transpose
10383 !-----------------------------------------------------------------------------
10384       subroutine prodmat3(a1,a2,kk,transp,prod)
10385 !DIR$ INLINEALWAYS prodmat3
10386 #ifndef OSF
10387 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10388 #endif
10389       implicit none
10390       integer :: i,j
10391       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10392       logical :: transp
10393 !rc      double precision auxmat(2,2),prod_(2,2)
10394
10395       if (transp) then
10396 !rc        call transpose2(kk(1,1),auxmat(1,1))
10397 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10398 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10399
10400            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10401        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10402            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10403        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10404            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10405        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10406            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10407        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10408
10409       else
10410 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10411 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10412
10413            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10414         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10415            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10416         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10417            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10418         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10419            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10420         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10421
10422       endif
10423 !      call transpose2(a2(1,1),a2t(1,1))
10424
10425 !rc      print *,transp
10426 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10427 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10428
10429       return
10430       end subroutine prodmat3
10431 !-----------------------------------------------------------------------------
10432 ! energy_p_new_barrier.F
10433 !-----------------------------------------------------------------------------
10434       subroutine sum_gradient
10435 !      implicit real*8 (a-h,o-z)
10436       use io_base, only: pdbout
10437 !      include 'DIMENSIONS'
10438 #ifndef ISNAN
10439       external proc_proc
10440 #ifdef WINPGI
10441 !MS$ATTRIBUTES C ::  proc_proc
10442 #endif
10443 #endif
10444 #ifdef MPI
10445       include 'mpif.h'
10446 #endif
10447       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10448                    gloc_scbuf !(3,maxres)
10449
10450       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10451 !#endif
10452 !el local variables
10453       integer :: i,j,k,ierror,ierr
10454       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10455                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10456                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10457                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10458                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10459                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10460                    gsccorr_max,gsccorrx_max,time00
10461
10462 !      include 'COMMON.SETUP'
10463 !      include 'COMMON.IOUNITS'
10464 !      include 'COMMON.FFIELD'
10465 !      include 'COMMON.DERIV'
10466 !      include 'COMMON.INTERACT'
10467 !      include 'COMMON.SBRIDGE'
10468 !      include 'COMMON.CHAIN'
10469 !      include 'COMMON.VAR'
10470 !      include 'COMMON.CONTROL'
10471 !      include 'COMMON.TIME1'
10472 !      include 'COMMON.MAXGRAD'
10473 !      include 'COMMON.SCCOR'
10474 #ifdef TIMING
10475       time01=MPI_Wtime()
10476 #endif
10477 #ifdef DEBUG
10478       write (iout,*) "sum_gradient gvdwc, gvdwx"
10479       do i=1,nres
10480         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10481          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10482       enddo
10483       call flush(iout)
10484 #endif
10485 #ifdef MPI
10486         gradbufc=0.0d0
10487         gradbufx=0.0d0
10488         gradbufc_sum=0.0d0
10489         gloc_scbuf=0.0d0
10490         glocbuf=0.0d0
10491 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10492         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10493           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10494 #endif
10495 !
10496 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10497 !            in virtual-bond-vector coordinates
10498 !
10499 #ifdef DEBUG
10500 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10501 !      do i=1,nres-1
10502 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10503 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10504 !      enddo
10505 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10506 !      do i=1,nres-1
10507 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10508 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10509 !      enddo
10510       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10511       do i=1,nres
10512         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10513          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10514          (gvdwc_scpp(j,i),j=1,3)
10515       enddo
10516       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10517       do i=1,nres
10518         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10519          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10520          (gelc_loc_long(j,i),j=1,3)
10521       enddo
10522       call flush(iout)
10523 #endif
10524 #ifdef SPLITELE
10525       do i=0,nct
10526         do j=1,3
10527           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10528                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10529                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10530                       wel_loc*gel_loc_long(j,i)+ &
10531                       wcorr*gradcorr_long(j,i)+ &
10532                       wcorr5*gradcorr5_long(j,i)+ &
10533                       wcorr6*gradcorr6_long(j,i)+ &
10534                       wturn6*gcorr6_turn_long(j,i)+ &
10535                       wstrain*ghpbc(j,i) &
10536                      +wliptran*gliptranc(j,i) &
10537                      +gradafm(j,i) &
10538                      +welec*gshieldc(j,i) &
10539                      +wcorr*gshieldc_ec(j,i) &
10540                      +wturn3*gshieldc_t3(j,i)&
10541                      +wturn4*gshieldc_t4(j,i)&
10542                      +wel_loc*gshieldc_ll(j,i)&
10543                      +wtube*gg_tube(j,i) &
10544                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10545                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10546                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10547                      wcorr_nucl*gradcorr_nucl(j,i)&
10548                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10549                      wcatprot* gradpepcat(j,i)+ &
10550                      wcatcat*gradcatcat(j,i)+   &
10551                      wscbase*gvdwc_scbase(j,i)+ &
10552                      wpepbase*gvdwc_pepbase(j,i)+&
10553                      wscpho*gvdwc_scpho(j,i)+   &
10554                      wpeppho*gvdwc_peppho(j,i)
10555
10556
10557
10558
10559
10560         enddo
10561       enddo
10562 #else
10563       do i=0,nct
10564         do j=1,3
10565           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10566                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10567                       welec*gelc_long(j,i)+ &
10568                       wbond*gradb(j,i)+ &
10569                       wel_loc*gel_loc_long(j,i)+ &
10570                       wcorr*gradcorr_long(j,i)+ &
10571                       wcorr5*gradcorr5_long(j,i)+ &
10572                       wcorr6*gradcorr6_long(j,i)+ &
10573                       wturn6*gcorr6_turn_long(j,i)+ &
10574                       wstrain*ghpbc(j,i) &
10575                      +wliptran*gliptranc(j,i) &
10576                      +gradafm(j,i) &
10577                      +welec*gshieldc(j,i)&
10578                      +wcorr*gshieldc_ec(j,i) &
10579                      +wturn4*gshieldc_t4(j,i) &
10580                      +wel_loc*gshieldc_ll(j,i)&
10581                      +wtube*gg_tube(j,i) &
10582                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10583                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10584                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10585                      wcorr_nucl*gradcorr_nucl(j,i) &
10586                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10587                      wcatprot* gradpepcat(j,i)+ &
10588                      wcatcat*gradcatcat(j,i)+   &
10589                      wscbase*gvdwc_scbase(j,i)  &
10590                      wpepbase*gvdwc_pepbase(j,i)+&
10591                      wscpho*gvdwc_scpho(j,i)+&
10592                      wpeppho*gvdwc_peppho(j,i)
10593
10594
10595         enddo
10596       enddo
10597 #endif
10598 #ifdef MPI
10599       if (nfgtasks.gt.1) then
10600       time00=MPI_Wtime()
10601 #ifdef DEBUG
10602       write (iout,*) "gradbufc before allreduce"
10603       do i=1,nres
10604         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10605       enddo
10606       call flush(iout)
10607 #endif
10608       do i=0,nres
10609         do j=1,3
10610           gradbufc_sum(j,i)=gradbufc(j,i)
10611         enddo
10612       enddo
10613 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10614 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10615 !      time_reduce=time_reduce+MPI_Wtime()-time00
10616 #ifdef DEBUG
10617 !      write (iout,*) "gradbufc_sum after allreduce"
10618 !      do i=1,nres
10619 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10620 !      enddo
10621 !      call flush(iout)
10622 #endif
10623 #ifdef TIMING
10624 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10625 #endif
10626       do i=0,nres
10627         do k=1,3
10628           gradbufc(k,i)=0.0d0
10629         enddo
10630       enddo
10631 #ifdef DEBUG
10632       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10633       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10634                         " jgrad_end  ",jgrad_end(i),&
10635                         i=igrad_start,igrad_end)
10636 #endif
10637 !
10638 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10639 ! do not parallelize this part.
10640 !
10641 !      do i=igrad_start,igrad_end
10642 !        do j=jgrad_start(i),jgrad_end(i)
10643 !          do k=1,3
10644 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10645 !          enddo
10646 !        enddo
10647 !      enddo
10648       do j=1,3
10649         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10650       enddo
10651       do i=nres-2,-1,-1
10652         do j=1,3
10653           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10654         enddo
10655       enddo
10656 #ifdef DEBUG
10657       write (iout,*) "gradbufc after summing"
10658       do i=1,nres
10659         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10660       enddo
10661       call flush(iout)
10662 #endif
10663       else
10664 #endif
10665 !el#define DEBUG
10666 #ifdef DEBUG
10667       write (iout,*) "gradbufc"
10668       do i=1,nres
10669         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10670       enddo
10671       call flush(iout)
10672 #endif
10673 !el#undef DEBUG
10674       do i=-1,nres
10675         do j=1,3
10676           gradbufc_sum(j,i)=gradbufc(j,i)
10677           gradbufc(j,i)=0.0d0
10678         enddo
10679       enddo
10680       do j=1,3
10681         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10682       enddo
10683       do i=nres-2,-1,-1
10684         do j=1,3
10685           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10686         enddo
10687       enddo
10688 !      do i=nnt,nres-1
10689 !        do k=1,3
10690 !          gradbufc(k,i)=0.0d0
10691 !        enddo
10692 !        do j=i+1,nres
10693 !          do k=1,3
10694 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10695 !          enddo
10696 !        enddo
10697 !      enddo
10698 !el#define DEBUG
10699 #ifdef DEBUG
10700       write (iout,*) "gradbufc after summing"
10701       do i=1,nres
10702         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10703       enddo
10704       call flush(iout)
10705 #endif
10706 !el#undef DEBUG
10707 #ifdef MPI
10708       endif
10709 #endif
10710       do k=1,3
10711         gradbufc(k,nres)=0.0d0
10712       enddo
10713 !el----------------
10714 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10715 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10716 !el-----------------
10717       do i=-1,nct
10718         do j=1,3
10719 #ifdef SPLITELE
10720           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10721                       wel_loc*gel_loc(j,i)+ &
10722                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10723                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10724                       wel_loc*gel_loc_long(j,i)+ &
10725                       wcorr*gradcorr_long(j,i)+ &
10726                       wcorr5*gradcorr5_long(j,i)+ &
10727                       wcorr6*gradcorr6_long(j,i)+ &
10728                       wturn6*gcorr6_turn_long(j,i))+ &
10729                       wbond*gradb(j,i)+ &
10730                       wcorr*gradcorr(j,i)+ &
10731                       wturn3*gcorr3_turn(j,i)+ &
10732                       wturn4*gcorr4_turn(j,i)+ &
10733                       wcorr5*gradcorr5(j,i)+ &
10734                       wcorr6*gradcorr6(j,i)+ &
10735                       wturn6*gcorr6_turn(j,i)+ &
10736                       wsccor*gsccorc(j,i) &
10737                      +wscloc*gscloc(j,i)  &
10738                      +wliptran*gliptranc(j,i) &
10739                      +gradafm(j,i) &
10740                      +welec*gshieldc(j,i) &
10741                      +welec*gshieldc_loc(j,i) &
10742                      +wcorr*gshieldc_ec(j,i) &
10743                      +wcorr*gshieldc_loc_ec(j,i) &
10744                      +wturn3*gshieldc_t3(j,i) &
10745                      +wturn3*gshieldc_loc_t3(j,i) &
10746                      +wturn4*gshieldc_t4(j,i) &
10747                      +wturn4*gshieldc_loc_t4(j,i) &
10748                      +wel_loc*gshieldc_ll(j,i) &
10749                      +wel_loc*gshieldc_loc_ll(j,i) &
10750                      +wtube*gg_tube(j,i) &
10751                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10752                      +wvdwpsb*gvdwpsb1(j,i))&
10753                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10754
10755 !                 if ((i.le.2).and.(i.ge.1))
10756 !                       print *,gradc(j,i,icg),&
10757 !                      gradbufc(j,i),welec*gelc(j,i), &
10758 !                      wel_loc*gel_loc(j,i), &
10759 !                      wscp*gvdwc_scpp(j,i), &
10760 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10761 !                      wel_loc*gel_loc_long(j,i), &
10762 !                      wcorr*gradcorr_long(j,i), &
10763 !                      wcorr5*gradcorr5_long(j,i), &
10764 !                      wcorr6*gradcorr6_long(j,i), &
10765 !                      wturn6*gcorr6_turn_long(j,i), &
10766 !                      wbond*gradb(j,i), &
10767 !                      wcorr*gradcorr(j,i), &
10768 !                      wturn3*gcorr3_turn(j,i), &
10769 !                      wturn4*gcorr4_turn(j,i), &
10770 !                      wcorr5*gradcorr5(j,i), &
10771 !                      wcorr6*gradcorr6(j,i), &
10772 !                      wturn6*gcorr6_turn(j,i), &
10773 !                      wsccor*gsccorc(j,i) &
10774 !                     ,wscloc*gscloc(j,i)  &
10775 !                     ,wliptran*gliptranc(j,i) &
10776 !                    ,gradafm(j,i) &
10777 !                     ,welec*gshieldc(j,i) &
10778 !                     ,welec*gshieldc_loc(j,i) &
10779 !                     ,wcorr*gshieldc_ec(j,i) &
10780 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10781 !                     ,wturn3*gshieldc_t3(j,i) &
10782 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10783 !                     ,wturn4*gshieldc_t4(j,i) &
10784 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10785 !                     ,wel_loc*gshieldc_ll(j,i) &
10786 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10787 !                     ,wtube*gg_tube(j,i) &
10788 !                     ,wbond_nucl*gradb_nucl(j,i) &
10789 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10790 !                     wvdwpsb*gvdwpsb1(j,i)&
10791 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10792 !
10793
10794 #else
10795           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10796                       wel_loc*gel_loc(j,i)+ &
10797                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10798                       welec*gelc_long(j,i)+ &
10799                       wel_loc*gel_loc_long(j,i)+ &
10800 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10801                       wcorr5*gradcorr5_long(j,i)+ &
10802                       wcorr6*gradcorr6_long(j,i)+ &
10803                       wturn6*gcorr6_turn_long(j,i))+ &
10804                       wbond*gradb(j,i)+ &
10805                       wcorr*gradcorr(j,i)+ &
10806                       wturn3*gcorr3_turn(j,i)+ &
10807                       wturn4*gcorr4_turn(j,i)+ &
10808                       wcorr5*gradcorr5(j,i)+ &
10809                       wcorr6*gradcorr6(j,i)+ &
10810                       wturn6*gcorr6_turn(j,i)+ &
10811                       wsccor*gsccorc(j,i) &
10812                      +wscloc*gscloc(j,i) &
10813                      +gradafm(j,i) &
10814                      +wliptran*gliptranc(j,i) &
10815                      +welec*gshieldc(j,i) &
10816                      +welec*gshieldc_loc(j,) &
10817                      +wcorr*gshieldc_ec(j,i) &
10818                      +wcorr*gshieldc_loc_ec(j,i) &
10819                      +wturn3*gshieldc_t3(j,i) &
10820                      +wturn3*gshieldc_loc_t3(j,i) &
10821                      +wturn4*gshieldc_t4(j,i) &
10822                      +wturn4*gshieldc_loc_t4(j,i) &
10823                      +wel_loc*gshieldc_ll(j,i) &
10824                      +wel_loc*gshieldc_loc_ll(j,i) &
10825                      +wtube*gg_tube(j,i) &
10826                      +wbond_nucl*gradb_nucl(j,i) &
10827                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10828                      +wvdwpsb*gvdwpsb1(j,i))&
10829                      +wsbloc*gsbloc(j,i)
10830
10831
10832
10833
10834 #endif
10835           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10836                         wbond*gradbx(j,i)+ &
10837                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10838                         wsccor*gsccorx(j,i) &
10839                        +wscloc*gsclocx(j,i) &
10840                        +wliptran*gliptranx(j,i) &
10841                        +welec*gshieldx(j,i)     &
10842                        +wcorr*gshieldx_ec(j,i)  &
10843                        +wturn3*gshieldx_t3(j,i) &
10844                        +wturn4*gshieldx_t4(j,i) &
10845                        +wel_loc*gshieldx_ll(j,i)&
10846                        +wtube*gg_tube_sc(j,i)   &
10847                        +wbond_nucl*gradbx_nucl(j,i) &
10848                        +wvdwsb*gvdwsbx(j,i) &
10849                        +welsb*gelsbx(j,i) &
10850                        +wcorr_nucl*gradxorr_nucl(j,i)&
10851                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10852                        +wsbloc*gsblocx(j,i) &
10853                        +wcatprot* gradpepcatx(j,i)&
10854                        +wscbase*gvdwx_scbase(j,i) &
10855                        +wpepbase*gvdwx_pepbase(j,i)&
10856                        +wscpho*gvdwx_scpho(j,i)
10857 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
10858
10859         enddo
10860       enddo
10861 #ifdef DEBUG
10862       write (iout,*) "gloc before adding corr"
10863       do i=1,4*nres
10864         write (iout,*) i,gloc(i,icg)
10865       enddo
10866 #endif
10867       do i=1,nres-3
10868         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10869          +wcorr5*g_corr5_loc(i) &
10870          +wcorr6*g_corr6_loc(i) &
10871          +wturn4*gel_loc_turn4(i) &
10872          +wturn3*gel_loc_turn3(i) &
10873          +wturn6*gel_loc_turn6(i) &
10874          +wel_loc*gel_loc_loc(i)
10875       enddo
10876 #ifdef DEBUG
10877       write (iout,*) "gloc after adding corr"
10878       do i=1,4*nres
10879         write (iout,*) i,gloc(i,icg)
10880       enddo
10881 #endif
10882 #ifdef MPI
10883       if (nfgtasks.gt.1) then
10884         do j=1,3
10885           do i=0,nres
10886             gradbufc(j,i)=gradc(j,i,icg)
10887             gradbufx(j,i)=gradx(j,i,icg)
10888           enddo
10889         enddo
10890         do i=1,4*nres
10891           glocbuf(i)=gloc(i,icg)
10892         enddo
10893 !#define DEBUG
10894 #ifdef DEBUG
10895       write (iout,*) "gloc_sc before reduce"
10896       do i=1,nres
10897        do j=1,1
10898         write (iout,*) i,j,gloc_sc(j,i,icg)
10899        enddo
10900       enddo
10901 #endif
10902 !#undef DEBUG
10903         do i=1,nres
10904          do j=1,3
10905           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10906          enddo
10907         enddo
10908         time00=MPI_Wtime()
10909         call MPI_Barrier(FG_COMM,IERR)
10910         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10911         time00=MPI_Wtime()
10912         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10913           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10914         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10915           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10916         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10917           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10918         time_reduce=time_reduce+MPI_Wtime()-time00
10919         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10920           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10921         time_reduce=time_reduce+MPI_Wtime()-time00
10922 !#define DEBUG
10923 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10924 #ifdef DEBUG
10925       write (iout,*) "gloc_sc after reduce"
10926       do i=1,nres
10927        do j=1,1
10928         write (iout,*) i,j,gloc_sc(j,i,icg)
10929        enddo
10930       enddo
10931 #endif
10932 !#undef DEBUG
10933 #ifdef DEBUG
10934       write (iout,*) "gloc after reduce"
10935       do i=1,4*nres
10936         write (iout,*) i,gloc(i,icg)
10937       enddo
10938 #endif
10939       endif
10940 #endif
10941       if (gnorm_check) then
10942 !
10943 ! Compute the maximum elements of the gradient
10944 !
10945       gvdwc_max=0.0d0
10946       gvdwc_scp_max=0.0d0
10947       gelc_max=0.0d0
10948       gvdwpp_max=0.0d0
10949       gradb_max=0.0d0
10950       ghpbc_max=0.0d0
10951       gradcorr_max=0.0d0
10952       gel_loc_max=0.0d0
10953       gcorr3_turn_max=0.0d0
10954       gcorr4_turn_max=0.0d0
10955       gradcorr5_max=0.0d0
10956       gradcorr6_max=0.0d0
10957       gcorr6_turn_max=0.0d0
10958       gsccorc_max=0.0d0
10959       gscloc_max=0.0d0
10960       gvdwx_max=0.0d0
10961       gradx_scp_max=0.0d0
10962       ghpbx_max=0.0d0
10963       gradxorr_max=0.0d0
10964       gsccorx_max=0.0d0
10965       gsclocx_max=0.0d0
10966       do i=1,nct
10967         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10968         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10969         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10970         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10971          gvdwc_scp_max=gvdwc_scp_norm
10972         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10973         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10974         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10975         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10976         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10977         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10978         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10979         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10980         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10981         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10982         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10983         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10984         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10985           gcorr3_turn(1,i)))
10986         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10987           gcorr3_turn_max=gcorr3_turn_norm
10988         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10989           gcorr4_turn(1,i)))
10990         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10991           gcorr4_turn_max=gcorr4_turn_norm
10992         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10993         if (gradcorr5_norm.gt.gradcorr5_max) &
10994           gradcorr5_max=gradcorr5_norm
10995         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10996         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10997         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10998           gcorr6_turn(1,i)))
10999         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11000           gcorr6_turn_max=gcorr6_turn_norm
11001         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11002         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11003         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11004         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11005         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11006         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11007         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11008         if (gradx_scp_norm.gt.gradx_scp_max) &
11009           gradx_scp_max=gradx_scp_norm
11010         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11011         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11012         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11013         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11014         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11015         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11016         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11017         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11018       enddo
11019       if (gradout) then
11020 #ifdef AIX
11021         open(istat,file=statname,position="append")
11022 #else
11023         open(istat,file=statname,access="append")
11024 #endif
11025         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11026            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11027            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11028            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11029            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11030            gsccorx_max,gsclocx_max
11031         close(istat)
11032         if (gvdwc_max.gt.1.0d4) then
11033           write (iout,*) "gvdwc gvdwx gradb gradbx"
11034           do i=nnt,nct
11035             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11036               gradb(j,i),gradbx(j,i),j=1,3)
11037           enddo
11038           call pdbout(0.0d0,'cipiszcze',iout)
11039           call flush(iout)
11040         endif
11041       endif
11042       endif
11043 !el#define DEBUG
11044 #ifdef DEBUG
11045       write (iout,*) "gradc gradx gloc"
11046       do i=1,nres
11047         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11048          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11049       enddo
11050 #endif
11051 !el#undef DEBUG
11052 #ifdef TIMING
11053       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11054 #endif
11055       return
11056       end subroutine sum_gradient
11057 !-----------------------------------------------------------------------------
11058       subroutine sc_grad
11059 !      implicit real*8 (a-h,o-z)
11060       use calc_data
11061 !      include 'DIMENSIONS'
11062 !      include 'COMMON.CHAIN'
11063 !      include 'COMMON.DERIV'
11064 !      include 'COMMON.CALC'
11065 !      include 'COMMON.IOUNITS'
11066       real(kind=8), dimension(3) :: dcosom1,dcosom2
11067 !      print *,"wchodze"
11068       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
11069       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
11070       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11071            -2.0D0*alf12*eps3der+sigder*sigsq_om12
11072 ! diagnostics only
11073 !      eom1=0.0d0
11074 !      eom2=0.0d0
11075 !      eom12=evdwij*eps1_om12
11076 ! end diagnostics
11077 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11078 !       " sigder",sigder
11079 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11080 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11081 !C      print *,sss_ele_cut,'in sc_grad'
11082       do k=1,3
11083         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11084         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11085       enddo
11086       do k=1,3
11087         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11088 !C      print *,'gg',k,gg(k)
11089        enddo
11090 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11091 !      write (iout,*) "gg",(gg(k),k=1,3)
11092       do k=1,3
11093         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11094                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11095                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11096                   *sss_ele_cut
11097
11098         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11099                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11100                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11101                   *sss_ele_cut
11102
11103 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11104 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11105 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11106 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11107       enddo
11108 !
11109 ! Calculate the components of the gradient in DC and X
11110 !
11111 !grad      do k=i,j-1
11112 !grad        do l=1,3
11113 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11114 !grad        enddo
11115 !grad      enddo
11116       do l=1,3
11117         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11118         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11119       enddo
11120       return
11121       end subroutine sc_grad
11122 #ifdef CRYST_THETA
11123 !-----------------------------------------------------------------------------
11124       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11125
11126       use comm_calcthet
11127 !      implicit real*8 (a-h,o-z)
11128 !      include 'DIMENSIONS'
11129 !      include 'COMMON.LOCAL'
11130 !      include 'COMMON.IOUNITS'
11131 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11132 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11133 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11134       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11135       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11136 !el      integer :: it
11137 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11138 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11139 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11140 !el local variables
11141
11142       delthec=thetai-thet_pred_mean
11143       delthe0=thetai-theta0i
11144 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11145       t3 = thetai-thet_pred_mean
11146       t6 = t3**2
11147       t9 = term1
11148       t12 = t3*sigcsq
11149       t14 = t12+t6*sigsqtc
11150       t16 = 1.0d0
11151       t21 = thetai-theta0i
11152       t23 = t21**2
11153       t26 = term2
11154       t27 = t21*t26
11155       t32 = termexp
11156       t40 = t32**2
11157       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11158        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11159        *(-t12*t9-ak*sig0inv*t27)
11160       return
11161       end subroutine mixder
11162 #endif
11163 !-----------------------------------------------------------------------------
11164 ! cartder.F
11165 !-----------------------------------------------------------------------------
11166       subroutine cartder
11167 !-----------------------------------------------------------------------------
11168 ! This subroutine calculates the derivatives of the consecutive virtual
11169 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11170 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11171 ! in the angles alpha and omega, describing the location of a side chain
11172 ! in its local coordinate system.
11173 !
11174 ! The derivatives are stored in the following arrays:
11175 !
11176 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11177 ! The structure is as follows:
11178 !
11179 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11180 ! dDC(x,3)/dT(4),...,dDC(z,3)/dT(4),dDC(x,3)/dP(4),dDC(y,4)/dP(4),dDC(z,4)/dP(4)
11181 !         . . . . . . . . . . . .  . . . . . .
11182 ! dDC(x,N-1)/dT(4),...,dDC(z,N-1)/dT(4),dDC(x,N-1)/dP(4),dDC(y,N-1)/dP(4),dDC(z,N-1)/dP(4)
11183 !                          .
11184 !                          .
11185 !                          .
11186 ! dDC(x,N-1)/dT(N),...,dDC(z,N-1)/dT(N),dDC(x,N-1)/dP(N),dDC(y,N-1)/dP(N),dDC(z,N-1)/dP(N)
11187 !
11188 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11189 ! The structure is same as above.
11190 !
11191 ! DCDS - the derivatives of the side chain vectors in the local spherical
11192 ! andgles alph and omega:
11193 !
11194 ! dX(x,2)/dA(2),dX(y,2)/dA(2),dX(z,2)/dA(2),dX(x,2)/dO(2),dX(y,2)/dO(2),dX(z,2)/dO(2)
11195 ! dX(x,3)/dA(3),dX(y,3)/dA(3),dX(z,3)/dA(3),dX(x,3)/dO(3),dX(y,3)/dO(3),dX(z,3)/dO(3)
11196 !                          .
11197 !                          .
11198 !                          .
11199 ! dX(x,N-1)/dA(N-1),dX(y,N-1)/dA(N-1),dX(z,N-1)/dA(N-1),dX(x,N-1)/dO(N-1),dX(y,N-1)/dO(N-1),dX(z,N-1)/dO(N-1)
11200 !
11201 ! Version of March '95, based on an early version of November '91.
11202 !
11203 !**********************************************************************
11204 !      implicit real*8 (a-h,o-z)
11205 !      include 'DIMENSIONS'
11206 !      include 'COMMON.VAR'
11207 !      include 'COMMON.CHAIN'
11208 !      include 'COMMON.DERIV'
11209 !      include 'COMMON.GEO'
11210 !      include 'COMMON.LOCAL'
11211 !      include 'COMMON.INTERACT'
11212       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11213       real(kind=8),dimension(3,3) :: dp,temp
11214 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11215       real(kind=8),dimension(3) :: xx,xx1
11216 !el local variables
11217       integer :: i,k,l,j,m,ind,ind1,jjj
11218       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11219                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11220                  sint2,xp,yp,xxp,yyp,zzp,dj
11221
11222 !      common /przechowalnia/ fromto
11223       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11224 ! get the position of the jth ijth fragment of the chain coordinate system
11225 ! in the fromto array.
11226 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11227 !
11228 !      maxdim=(nres-1)*(nres-2)/2
11229 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11230 ! calculate the derivatives of transformation matrix elements in theta
11231 !
11232
11233 !el      call flush(iout) !el
11234       do i=1,nres-2
11235         rdt(1,1,i)=-rt(1,2,i)
11236         rdt(1,2,i)= rt(1,1,i)
11237         rdt(1,3,i)= 0.0d0
11238         rdt(2,1,i)=-rt(2,2,i)
11239         rdt(2,2,i)= rt(2,1,i)
11240         rdt(2,3,i)= 0.0d0
11241         rdt(3,1,i)=-rt(3,2,i)
11242         rdt(3,2,i)= rt(3,1,i)
11243         rdt(3,3,i)= 0.0d0
11244       enddo
11245 !
11246 ! derivatives in phi
11247 !
11248       do i=2,nres-2
11249         drt(1,1,i)= 0.0d0
11250         drt(1,2,i)= 0.0d0
11251         drt(1,3,i)= 0.0d0
11252         drt(2,1,i)= rt(3,1,i)
11253         drt(2,2,i)= rt(3,2,i)
11254         drt(2,3,i)= rt(3,3,i)
11255         drt(3,1,i)=-rt(2,1,i)
11256         drt(3,2,i)=-rt(2,2,i)
11257         drt(3,3,i)=-rt(2,3,i)
11258       enddo
11259 !
11260 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11261 !
11262       do i=2,nres-2
11263         ind=indmat(i,i+1)
11264         do k=1,3
11265           do l=1,3
11266             temp(k,l)=rt(k,l,i)
11267           enddo
11268         enddo
11269         do k=1,3
11270           do l=1,3
11271             fromto(k,l,ind)=temp(k,l)
11272           enddo
11273         enddo
11274         do j=i+1,nres-2
11275           ind=indmat(i,j+1)
11276           do k=1,3
11277             do l=1,3
11278               dpkl=0.0d0
11279               do m=1,3
11280                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11281               enddo
11282               dp(k,l)=dpkl
11283               fromto(k,l,ind)=dpkl
11284             enddo
11285           enddo
11286           do k=1,3
11287             do l=1,3
11288               temp(k,l)=dp(k,l)
11289             enddo
11290           enddo
11291         enddo
11292       enddo
11293 !
11294 ! Calculate derivatives.
11295 !
11296       ind1=0
11297       do i=1,nres-2
11298       ind1=ind1+1
11299 !
11300 ! Derivatives of DC(i+1) in theta(i+2)
11301 !
11302         do j=1,3
11303           do k=1,2
11304             dpjk=0.0D0
11305             do l=1,3
11306               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11307             enddo
11308             dp(j,k)=dpjk
11309             prordt(j,k,i)=dp(j,k)
11310           enddo
11311           dp(j,3)=0.0D0
11312           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11313         enddo
11314 !
11315 ! Derivatives of SC(i+1) in theta(i+2)
11316 !
11317         xx1(1)=-0.5D0*xloc(2,i+1)
11318         xx1(2)= 0.5D0*xloc(1,i+1)
11319         do j=1,3
11320           xj=0.0D0
11321           do k=1,2
11322             xj=xj+r(j,k,i)*xx1(k)
11323           enddo
11324           xx(j)=xj
11325         enddo
11326         do j=1,3
11327           rj=0.0D0
11328           do k=1,3
11329             rj=rj+prod(j,k,i)*xx(k)
11330           enddo
11331           dxdv(j,ind1)=rj
11332         enddo
11333 !
11334 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11335 ! than the other off-diagonal derivatives.
11336 !
11337         do j=1,3
11338           dxoiij=0.0D0
11339           do k=1,3
11340             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11341           enddo
11342           dxdv(j,ind1+1)=dxoiij
11343         enddo
11344 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11345 !
11346 ! Derivatives of DC(i+1) in phi(i+2)
11347 !
11348         do j=1,3
11349           do k=1,3
11350             dpjk=0.0
11351             do l=2,3
11352               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11353             enddo
11354             dp(j,k)=dpjk
11355             prodrt(j,k,i)=dp(j,k)
11356           enddo
11357           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11358         enddo
11359 !
11360 ! Derivatives of SC(i+1) in phi(i+2)
11361 !
11362         xx(1)= 0.0D0
11363         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11364         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11365         do j=1,3
11366           rj=0.0D0
11367           do k=2,3
11368             rj=rj+prod(j,k,i)*xx(k)
11369           enddo
11370           dxdv(j+3,ind1)=-rj
11371         enddo
11372 !
11373 ! Derivatives of SC(i+1) in phi(i+3).
11374 !
11375         do j=1,3
11376           dxoiij=0.0D0
11377           do k=1,3
11378             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11379           enddo
11380           dxdv(j+3,ind1+1)=dxoiij
11381         enddo
11382 !
11383 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11384 ! theta(nres) and phi(i+3) thru phi(nres).
11385 !
11386         do j=i+1,nres-2
11387         ind1=ind1+1
11388         ind=indmat(i+1,j+1)
11389 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11390           do k=1,3
11391             do l=1,3
11392               tempkl=0.0D0
11393               do m=1,2
11394                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11395               enddo
11396               temp(k,l)=tempkl
11397             enddo
11398           enddo
11399 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11400 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11401 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11402 ! Derivatives of virtual-bond vectors in theta
11403           do k=1,3
11404             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11405           enddo
11406 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11407 ! Derivatives of SC vectors in theta
11408           do k=1,3
11409             dxoijk=0.0D0
11410             do l=1,3
11411               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11412             enddo
11413             dxdv(k,ind1+1)=dxoijk
11414           enddo
11415 !
11416 !--- Calculate the derivatives in phi
11417 !
11418           do k=1,3
11419             do l=1,3
11420               tempkl=0.0D0
11421               do m=1,3
11422                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11423               enddo
11424               temp(k,l)=tempkl
11425             enddo
11426           enddo
11427           do k=1,3
11428             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11429         enddo
11430           do k=1,3
11431             dxoijk=0.0D0
11432             do l=1,3
11433               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11434             enddo
11435             dxdv(k+3,ind1+1)=dxoijk
11436           enddo
11437         enddo
11438       enddo
11439 !
11440 ! Derivatives in alpha and omega:
11441 !
11442       do i=2,nres-1
11443 !       dsci=dsc(itype(i,1))
11444         dsci=vbld(i+nres)
11445 #ifdef OSF
11446         alphi=alph(i)
11447         omegi=omeg(i)
11448         if(alphi.ne.alphi) alphi=100.0
11449         if(omegi.ne.omegi) omegi=-100.0
11450 #else
11451       alphi=alph(i)
11452       omegi=omeg(i)
11453 #endif
11454 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11455       cosalphi=dcos(alphi)
11456       sinalphi=dsin(alphi)
11457       cosomegi=dcos(omegi)
11458       sinomegi=dsin(omegi)
11459       temp(1,1)=-dsci*sinalphi
11460       temp(2,1)= dsci*cosalphi*cosomegi
11461       temp(3,1)=-dsci*cosalphi*sinomegi
11462       temp(1,2)=0.0D0
11463       temp(2,2)=-dsci*sinalphi*sinomegi
11464       temp(3,2)=-dsci*sinalphi*cosomegi
11465       theta2=pi-0.5D0*theta(i+1)
11466       cost2=dcos(theta2)
11467       sint2=dsin(theta2)
11468       jjj=0
11469 !d      print *,((temp(l,k),l=1,3),k=1,2)
11470         do j=1,2
11471         xp=temp(1,j)
11472         yp=temp(2,j)
11473         xxp= xp*cost2+yp*sint2
11474         yyp=-xp*sint2+yp*cost2
11475         zzp=temp(3,j)
11476         xx(1)=xxp
11477         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11478         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11479         do k=1,3
11480           dj=0.0D0
11481           do l=1,3
11482             dj=dj+prod(k,l,i-1)*xx(l)
11483             enddo
11484           dxds(jjj+k,i)=dj
11485           enddo
11486         jjj=jjj+3
11487       enddo
11488       enddo
11489       return
11490       end subroutine cartder
11491 !-----------------------------------------------------------------------------
11492 ! checkder_p.F
11493 !-----------------------------------------------------------------------------
11494       subroutine check_cartgrad
11495 ! Check the gradient of Cartesian coordinates in internal coordinates.
11496 !      implicit real*8 (a-h,o-z)
11497 !      include 'DIMENSIONS'
11498 !      include 'COMMON.IOUNITS'
11499 !      include 'COMMON.VAR'
11500 !      include 'COMMON.CHAIN'
11501 !      include 'COMMON.GEO'
11502 !      include 'COMMON.LOCAL'
11503 !      include 'COMMON.DERIV'
11504       real(kind=8),dimension(6,nres) :: temp
11505       real(kind=8),dimension(3) :: xx,gg
11506       integer :: i,k,j,ii
11507       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11508 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11509 !
11510 ! Check the gradient of the virtual-bond and SC vectors in the internal
11511 ! coordinates.
11512 !
11513       aincr=1.0d-6
11514       aincr2=5.0d-7
11515       call cartder
11516       write (iout,'(a)') '**************** dx/dalpha'
11517       write (iout,'(a)')
11518       do i=2,nres-1
11519       alphi=alph(i)
11520       alph(i)=alph(i)+aincr
11521       do k=1,3
11522         temp(k,i)=dc(k,nres+i)
11523         enddo
11524       call chainbuild
11525       do k=1,3
11526         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11527         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11528         enddo
11529         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11530         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11531         write (iout,'(a)')
11532       alph(i)=alphi
11533       call chainbuild
11534       enddo
11535       write (iout,'(a)')
11536       write (iout,'(a)') '**************** dx/domega'
11537       write (iout,'(a)')
11538       do i=2,nres-1
11539       omegi=omeg(i)
11540       omeg(i)=omeg(i)+aincr
11541       do k=1,3
11542         temp(k,i)=dc(k,nres+i)
11543         enddo
11544       call chainbuild
11545       do k=1,3
11546           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11547           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11548                 (aincr*dabs(dxds(k+3,i))+aincr))
11549         enddo
11550         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11551             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11552         write (iout,'(a)')
11553       omeg(i)=omegi
11554       call chainbuild
11555       enddo
11556       write (iout,'(a)')
11557       write (iout,'(a)') '**************** dx/dtheta'
11558       write (iout,'(a)')
11559       do i=3,nres
11560       theti=theta(i)
11561         theta(i)=theta(i)+aincr
11562         do j=i-1,nres-1
11563           do k=1,3
11564             temp(k,j)=dc(k,nres+j)
11565           enddo
11566         enddo
11567         call chainbuild
11568         do j=i-1,nres-1
11569         ii = indmat(i-2,j)
11570 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11571         do k=1,3
11572           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11573           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11574                   (aincr*dabs(dxdv(k,ii))+aincr))
11575           enddo
11576           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11577               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11578           write(iout,'(a)')
11579         enddo
11580         write (iout,'(a)')
11581         theta(i)=theti
11582         call chainbuild
11583       enddo
11584       write (iout,'(a)') '***************** dx/dphi'
11585       write (iout,'(a)')
11586       do i=4,nres
11587         phi(i)=phi(i)+aincr
11588         do j=i-1,nres-1
11589           do k=1,3
11590             temp(k,j)=dc(k,nres+j)
11591           enddo
11592         enddo
11593         call chainbuild
11594         do j=i-1,nres-1
11595         ii = indmat(i-2,j)
11596 !         print *,'ii=',ii
11597         do k=1,3
11598           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11599             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11600                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11601           enddo
11602           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11603               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11604           write(iout,'(a)')
11605         enddo
11606         phi(i)=phi(i)-aincr
11607         call chainbuild
11608       enddo
11609       write (iout,'(a)') '****************** ddc/dtheta'
11610       do i=1,nres-2
11611         thet=theta(i+2)
11612         theta(i+2)=thet+aincr
11613         do j=i,nres
11614           do k=1,3
11615             temp(k,j)=dc(k,j)
11616           enddo
11617         enddo
11618         call chainbuild
11619         do j=i+1,nres-1
11620         ii = indmat(i,j)
11621 !         print *,'ii=',ii
11622         do k=1,3
11623           gg(k)=(dc(k,j)-temp(k,j))/aincr
11624           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11625                  (aincr*dabs(dcdv(k,ii))+aincr))
11626           enddo
11627           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11628                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11629         write (iout,'(a)')
11630         enddo
11631         do j=1,nres
11632           do k=1,3
11633             dc(k,j)=temp(k,j)
11634           enddo
11635         enddo
11636         theta(i+2)=thet
11637       enddo
11638       write (iout,'(a)') '******************* ddc/dphi'
11639       do i=1,nres-3
11640         phii=phi(i+3)
11641         phi(i+3)=phii+aincr
11642         do j=1,nres
11643           do k=1,3
11644             temp(k,j)=dc(k,j)
11645           enddo
11646         enddo
11647         call chainbuild
11648         do j=i+2,nres-1
11649         ii = indmat(i+1,j)
11650 !         print *,'ii=',ii
11651         do k=1,3
11652           gg(k)=(dc(k,j)-temp(k,j))/aincr
11653             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11654                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11655           enddo
11656           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11657                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11658         write (iout,'(a)')
11659         enddo
11660         do j=1,nres
11661           do k=1,3
11662             dc(k,j)=temp(k,j)
11663           enddo
11664         enddo
11665         phi(i+3)=phii
11666       enddo
11667       return
11668       end subroutine check_cartgrad
11669 !-----------------------------------------------------------------------------
11670       subroutine check_ecart
11671 ! Check the gradient of the energy in Cartesian coordinates.
11672 !     implicit real*8 (a-h,o-z)
11673 !     include 'DIMENSIONS'
11674 !     include 'COMMON.CHAIN'
11675 !     include 'COMMON.DERIV'
11676 !     include 'COMMON.IOUNITS'
11677 !     include 'COMMON.VAR'
11678 !     include 'COMMON.CONTACTS'
11679       use comm_srutu
11680 !el      integer :: icall
11681 !el      common /srutu/ icall
11682       real(kind=8),dimension(6) :: ggg
11683       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11684       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11685       real(kind=8),dimension(6,nres) :: grad_s
11686       real(kind=8),dimension(0:n_ene) :: energia,energia1
11687       integer :: uiparm(1)
11688       real(kind=8) :: urparm(1)
11689 !EL      external fdum
11690       integer :: nf,i,j,k
11691       real(kind=8) :: aincr,etot,etot1
11692       icg=1
11693       nf=0
11694       nfl=0
11695       call zerograd
11696       aincr=1.0D-5
11697       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11698       nf=0
11699       icall=0
11700       call geom_to_var(nvar,x)
11701       call etotal(energia)
11702       etot=energia(0)
11703 !el      call enerprint(energia)
11704       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11705       icall =1
11706       do i=1,nres
11707         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11708       enddo
11709       do i=1,nres
11710       do j=1,3
11711         grad_s(j,i)=gradc(j,i,icg)
11712         grad_s(j+3,i)=gradx(j,i,icg)
11713         enddo
11714       enddo
11715       call flush(iout)
11716       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11717       do i=1,nres
11718         do j=1,3
11719         xx(j)=c(j,i+nres)
11720         ddc(j)=dc(j,i)
11721         ddx(j)=dc(j,i+nres)
11722         enddo
11723       do j=1,3
11724         dc(j,i)=dc(j,i)+aincr
11725         do k=i+1,nres
11726           c(j,k)=c(j,k)+aincr
11727           c(j,k+nres)=c(j,k+nres)+aincr
11728           enddo
11729           call etotal(energia1)
11730           etot1=energia1(0)
11731         ggg(j)=(etot1-etot)/aincr
11732         dc(j,i)=ddc(j)
11733         do k=i+1,nres
11734           c(j,k)=c(j,k)-aincr
11735           c(j,k+nres)=c(j,k+nres)-aincr
11736           enddo
11737         enddo
11738       do j=1,3
11739         c(j,i+nres)=c(j,i+nres)+aincr
11740         dc(j,i+nres)=dc(j,i+nres)+aincr
11741           call etotal(energia1)
11742           etot1=energia1(0)
11743         ggg(j+3)=(etot1-etot)/aincr
11744         c(j,i+nres)=xx(j)
11745         dc(j,i+nres)=ddx(j)
11746         enddo
11747       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11748          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11749       enddo
11750       return
11751       end subroutine check_ecart
11752 #ifdef CARGRAD
11753 !-----------------------------------------------------------------------------
11754       subroutine check_ecartint
11755 ! Check the gradient of the energy in Cartesian coordinates.
11756       use io_base, only: intout
11757 !      implicit real*8 (a-h,o-z)
11758 !      include 'DIMENSIONS'
11759 !      include 'COMMON.CONTROL'
11760 !      include 'COMMON.CHAIN'
11761 !      include 'COMMON.DERIV'
11762 !      include 'COMMON.IOUNITS'
11763 !      include 'COMMON.VAR'
11764 !      include 'COMMON.CONTACTS'
11765 !      include 'COMMON.MD'
11766 !      include 'COMMON.LOCAL'
11767 !      include 'COMMON.SPLITELE'
11768       use comm_srutu
11769 !el      integer :: icall
11770 !el      common /srutu/ icall
11771       real(kind=8),dimension(6) :: ggg,ggg1
11772       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11773       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11774       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11775       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11776       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11777       real(kind=8),dimension(0:n_ene) :: energia,energia1
11778       integer :: uiparm(1)
11779       real(kind=8) :: urparm(1)
11780 !EL      external fdum
11781       integer :: i,j,k,nf
11782       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11783                    etot21,etot22
11784       r_cut=2.0d0
11785       rlambd=0.3d0
11786       icg=1
11787       nf=0
11788       nfl=0
11789       call intout
11790 !      call intcartderiv
11791 !      call checkintcartgrad
11792       call zerograd
11793       aincr=1.0D-5
11794       write(iout,*) 'Calling CHECK_ECARTINT.'
11795       nf=0
11796       icall=0
11797       write (iout,*) "Before geom_to_var"
11798       call geom_to_var(nvar,x)
11799       write (iout,*) "after geom_to_var"
11800       write (iout,*) "split_ene ",split_ene
11801       call flush(iout)
11802       if (.not.split_ene) then
11803         write(iout,*) 'Calling CHECK_ECARTINT if'
11804         call etotal(energia)
11805 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11806         etot=energia(0)
11807         write (iout,*) "etot",etot
11808         call flush(iout)
11809 !el        call enerprint(energia)
11810 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11811         call flush(iout)
11812         write (iout,*) "enter cartgrad"
11813         call flush(iout)
11814         call cartgrad
11815 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11816         write (iout,*) "exit cartgrad"
11817         call flush(iout)
11818         icall =1
11819         do i=1,nres
11820           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11821         enddo
11822         do j=1,3
11823           grad_s(j,0)=gcart(j,0)
11824         enddo
11825 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11826         do i=1,nres
11827           do j=1,3
11828             grad_s(j,i)=gcart(j,i)
11829             grad_s(j+3,i)=gxcart(j,i)
11830           enddo
11831         enddo
11832       else
11833 write(iout,*) 'Calling CHECK_ECARTIN else.'
11834 !- split gradient check
11835         call zerograd
11836         call etotal_long(energia)
11837 !el        call enerprint(energia)
11838         call flush(iout)
11839         write (iout,*) "enter cartgrad"
11840         call flush(iout)
11841         call cartgrad
11842         write (iout,*) "exit cartgrad"
11843         call flush(iout)
11844         icall =1
11845         write (iout,*) "longrange grad"
11846         do i=1,nres
11847           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11848           (gxcart(j,i),j=1,3)
11849         enddo
11850         do j=1,3
11851           grad_s(j,0)=gcart(j,0)
11852         enddo
11853         do i=1,nres
11854           do j=1,3
11855             grad_s(j,i)=gcart(j,i)
11856             grad_s(j+3,i)=gxcart(j,i)
11857           enddo
11858         enddo
11859         call zerograd
11860         call etotal_short(energia)
11861         call enerprint(energia)
11862         call flush(iout)
11863         write (iout,*) "enter cartgrad"
11864         call flush(iout)
11865         call cartgrad
11866         write (iout,*) "exit cartgrad"
11867         call flush(iout)
11868         icall =1
11869         write (iout,*) "shortrange grad"
11870         do i=1,nres
11871           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11872           (gxcart(j,i),j=1,3)
11873         enddo
11874         do j=1,3
11875           grad_s1(j,0)=gcart(j,0)
11876         enddo
11877         do i=1,nres
11878           do j=1,3
11879             grad_s1(j,i)=gcart(j,i)
11880             grad_s1(j+3,i)=gxcart(j,i)
11881           enddo
11882         enddo
11883       endif
11884       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11885 !      do i=1,nres
11886       do i=nnt,nct
11887         do j=1,3
11888           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11889           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11890         ddc(j)=c(j,i)
11891         ddx(j)=c(j,i+nres)
11892           dcnorm_safe1(j)=dc_norm(j,i-1)
11893           dcnorm_safe2(j)=dc_norm(j,i)
11894           dxnorm_safe(j)=dc_norm(j,i+nres)
11895         enddo
11896       do j=1,3
11897         c(j,i)=ddc(j)+aincr
11898           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11899           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11900           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11901           dc(j,i)=c(j,i+1)-c(j,i)
11902           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11903           call int_from_cart1(.false.)
11904           if (.not.split_ene) then
11905             call etotal(energia1)
11906             etot1=energia1(0)
11907             write (iout,*) "ij",i,j," etot1",etot1
11908           else
11909 !- split gradient
11910             call etotal_long(energia1)
11911             etot11=energia1(0)
11912             call etotal_short(energia1)
11913             etot12=energia1(0)
11914           endif
11915 !- end split gradient
11916 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11917         c(j,i)=ddc(j)-aincr
11918           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11919           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11920           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11921           dc(j,i)=c(j,i+1)-c(j,i)
11922           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11923           call int_from_cart1(.false.)
11924           if (.not.split_ene) then
11925             call etotal(energia1)
11926             etot2=energia1(0)
11927             write (iout,*) "ij",i,j," etot2",etot2
11928           ggg(j)=(etot1-etot2)/(2*aincr)
11929           else
11930 !- split gradient
11931             call etotal_long(energia1)
11932             etot21=energia1(0)
11933           ggg(j)=(etot11-etot21)/(2*aincr)
11934             call etotal_short(energia1)
11935             etot22=energia1(0)
11936           ggg1(j)=(etot12-etot22)/(2*aincr)
11937 !- end split gradient
11938 !            write (iout,*) "etot21",etot21," etot22",etot22
11939           endif
11940 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11941         c(j,i)=ddc(j)
11942           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11943           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11944           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11945           dc(j,i)=c(j,i+1)-c(j,i)
11946           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11947           dc_norm(j,i-1)=dcnorm_safe1(j)
11948           dc_norm(j,i)=dcnorm_safe2(j)
11949           dc_norm(j,i+nres)=dxnorm_safe(j)
11950         enddo
11951       do j=1,3
11952         c(j,i+nres)=ddx(j)+aincr
11953           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11954           call int_from_cart1(.false.)
11955           if (.not.split_ene) then
11956             call etotal(energia1)
11957             etot1=energia1(0)
11958           else
11959 !- split gradient
11960             call etotal_long(energia1)
11961             etot11=energia1(0)
11962             call etotal_short(energia1)
11963             etot12=energia1(0)
11964           endif
11965 !- end split gradient
11966         c(j,i+nres)=ddx(j)-aincr
11967           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11968           call int_from_cart1(.false.)
11969           if (.not.split_ene) then
11970             call etotal(energia1)
11971             etot2=energia1(0)
11972           ggg(j+3)=(etot1-etot2)/(2*aincr)
11973           else
11974 !- split gradient
11975             call etotal_long(energia1)
11976             etot21=energia1(0)
11977           ggg(j+3)=(etot11-etot21)/(2*aincr)
11978             call etotal_short(energia1)
11979             etot22=energia1(0)
11980           ggg1(j+3)=(etot12-etot22)/(2*aincr)
11981 !- end split gradient
11982           endif
11983 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11984         c(j,i+nres)=ddx(j)
11985           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11986           dc_norm(j,i+nres)=dxnorm_safe(j)
11987           call int_from_cart1(.false.)
11988         enddo
11989       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11990          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11991         if (split_ene) then
11992           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11993          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11994          k=1,6)
11995          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11996          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11997          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11998         endif
11999       enddo
12000       return
12001       end subroutine check_ecartint
12002 #else
12003 !-----------------------------------------------------------------------------
12004       subroutine check_ecartint
12005 ! Check the gradient of the energy in Cartesian coordinates.
12006       use io_base, only: intout
12007 !      implicit real*8 (a-h,o-z)
12008 !      include 'DIMENSIONS'
12009 !      include 'COMMON.CONTROL'
12010 !      include 'COMMON.CHAIN'
12011 !      include 'COMMON.DERIV'
12012 !      include 'COMMON.IOUNITS'
12013 !      include 'COMMON.VAR'
12014 !      include 'COMMON.CONTACTS'
12015 !      include 'COMMON.MD'
12016 !      include 'COMMON.LOCAL'
12017 !      include 'COMMON.SPLITELE'
12018       use comm_srutu
12019 !el      integer :: icall
12020 !el      common /srutu/ icall
12021       real(kind=8),dimension(6) :: ggg,ggg1
12022       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12023       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12024       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12025       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12026       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12027       real(kind=8),dimension(0:n_ene) :: energia,energia1
12028       integer :: uiparm(1)
12029       real(kind=8) :: urparm(1)
12030 !EL      external fdum
12031       integer :: i,j,k,nf
12032       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12033                    etot21,etot22
12034       r_cut=2.0d0
12035       rlambd=0.3d0
12036       icg=1
12037       nf=0
12038       nfl=0
12039       call intout
12040 !      call intcartderiv
12041 !      call checkintcartgrad
12042       call zerograd
12043       aincr=2.0D-5
12044       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12045       nf=0
12046       icall=0
12047       call geom_to_var(nvar,x)
12048       if (.not.split_ene) then
12049         call etotal(energia)
12050         etot=energia(0)
12051 !el        call enerprint(energia)
12052         call flush(iout)
12053         write (iout,*) "enter cartgrad"
12054         call flush(iout)
12055         call cartgrad
12056         write (iout,*) "exit cartgrad"
12057         call flush(iout)
12058         icall =1
12059         do i=1,nres
12060           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12061         enddo
12062         do j=1,3
12063           grad_s(j,0)=gcart(j,0)
12064         enddo
12065         do i=1,nres
12066           do j=1,3
12067             grad_s(j,i)=gcart(j,i)
12068 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12069             grad_s(j+3,i)=gxcart(j,i)
12070           enddo
12071         enddo
12072       else
12073 !- split gradient check
12074         call zerograd
12075         call etotal_long(energia)
12076 !el        call enerprint(energia)
12077         call flush(iout)
12078         write (iout,*) "enter cartgrad"
12079         call flush(iout)
12080         call cartgrad
12081         write (iout,*) "exit cartgrad"
12082         call flush(iout)
12083         icall =1
12084         write (iout,*) "longrange grad"
12085         do i=1,nres
12086           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12087           (gxcart(j,i),j=1,3)
12088         enddo
12089         do j=1,3
12090           grad_s(j,0)=gcart(j,0)
12091         enddo
12092         do i=1,nres
12093           do j=1,3
12094             grad_s(j,i)=gcart(j,i)
12095             grad_s(j+3,i)=gxcart(j,i)
12096           enddo
12097         enddo
12098         call zerograd
12099         call etotal_short(energia)
12100 !el        call enerprint(energia)
12101         call flush(iout)
12102         write (iout,*) "enter cartgrad"
12103         call flush(iout)
12104         call cartgrad
12105         write (iout,*) "exit cartgrad"
12106         call flush(iout)
12107         icall =1
12108         write (iout,*) "shortrange grad"
12109         do i=1,nres
12110           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12111           (gxcart(j,i),j=1,3)
12112         enddo
12113         do j=1,3
12114           grad_s1(j,0)=gcart(j,0)
12115         enddo
12116         do i=1,nres
12117           do j=1,3
12118             grad_s1(j,i)=gcart(j,i)
12119             grad_s1(j+3,i)=gxcart(j,i)
12120           enddo
12121         enddo
12122       endif
12123       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12124       do i=0,nres
12125         do j=1,3
12126         xx(j)=c(j,i+nres)
12127         ddc(j)=dc(j,i)
12128         ddx(j)=dc(j,i+nres)
12129           do k=1,3
12130             dcnorm_safe(k)=dc_norm(k,i)
12131             dxnorm_safe(k)=dc_norm(k,i+nres)
12132           enddo
12133         enddo
12134       do j=1,3
12135         dc(j,i)=ddc(j)+aincr
12136           call chainbuild_cart
12137 #ifdef MPI
12138 ! Broadcast the order to compute internal coordinates to the slaves.
12139 !          if (nfgtasks.gt.1)
12140 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12141 #endif
12142 !          call int_from_cart1(.false.)
12143           if (.not.split_ene) then
12144             call etotal(energia1)
12145             etot1=energia1(0)
12146 !            call enerprint(energia1)
12147           else
12148 !- split gradient
12149             call etotal_long(energia1)
12150             etot11=energia1(0)
12151             call etotal_short(energia1)
12152             etot12=energia1(0)
12153 !            write (iout,*) "etot11",etot11," etot12",etot12
12154           endif
12155 !- end split gradient
12156 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12157         dc(j,i)=ddc(j)-aincr
12158           call chainbuild_cart
12159 !          call int_from_cart1(.false.)
12160           if (.not.split_ene) then
12161             call etotal(energia1)
12162             etot2=energia1(0)
12163           ggg(j)=(etot1-etot2)/(2*aincr)
12164           else
12165 !- split gradient
12166             call etotal_long(energia1)
12167             etot21=energia1(0)
12168           ggg(j)=(etot11-etot21)/(2*aincr)
12169             call etotal_short(energia1)
12170             etot22=energia1(0)
12171           ggg1(j)=(etot12-etot22)/(2*aincr)
12172 !- end split gradient
12173 !            write (iout,*) "etot21",etot21," etot22",etot22
12174           endif
12175 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12176         dc(j,i)=ddc(j)
12177           call chainbuild_cart
12178         enddo
12179       do j=1,3
12180         dc(j,i+nres)=ddx(j)+aincr
12181           call chainbuild_cart
12182 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12183 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12184 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12185 !          write (iout,*) "dxnormnorm",dsqrt(
12186 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12187 !          write (iout,*) "dxnormnormsafe",dsqrt(
12188 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12189 !          write (iout,*)
12190           if (.not.split_ene) then
12191             call etotal(energia1)
12192             etot1=energia1(0)
12193           else
12194 !- split gradient
12195             call etotal_long(energia1)
12196             etot11=energia1(0)
12197             call etotal_short(energia1)
12198             etot12=energia1(0)
12199           endif
12200 !- end split gradient
12201 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12202         dc(j,i+nres)=ddx(j)-aincr
12203           call chainbuild_cart
12204 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12205 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12206 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12207 !          write (iout,*)
12208 !          write (iout,*) "dxnormnorm",dsqrt(
12209 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12210 !          write (iout,*) "dxnormnormsafe",dsqrt(
12211 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12212           if (.not.split_ene) then
12213             call etotal(energia1)
12214             etot2=energia1(0)
12215           ggg(j+3)=(etot1-etot2)/(2*aincr)
12216           else
12217 !- split gradient
12218             call etotal_long(energia1)
12219             etot21=energia1(0)
12220           ggg(j+3)=(etot11-etot21)/(2*aincr)
12221             call etotal_short(energia1)
12222             etot22=energia1(0)
12223           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12224 !- end split gradient
12225           endif
12226 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12227         dc(j,i+nres)=ddx(j)
12228           call chainbuild_cart
12229         enddo
12230       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12231          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12232         if (split_ene) then
12233           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12234          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12235          k=1,6)
12236          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12237          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12238          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12239         endif
12240       enddo
12241       return
12242       end subroutine check_ecartint
12243 #endif
12244 !-----------------------------------------------------------------------------
12245       subroutine check_eint
12246 ! Check the gradient of energy in internal coordinates.
12247 !      implicit real*8 (a-h,o-z)
12248 !      include 'DIMENSIONS'
12249 !      include 'COMMON.CHAIN'
12250 !      include 'COMMON.DERIV'
12251 !      include 'COMMON.IOUNITS'
12252 !      include 'COMMON.VAR'
12253 !      include 'COMMON.GEO'
12254       use comm_srutu
12255 !el      integer :: icall
12256 !el      common /srutu/ icall
12257       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12258       integer :: uiparm(1)
12259       real(kind=8) :: urparm(1)
12260       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12261       character(len=6) :: key
12262 !EL      external fdum
12263       integer :: i,ii,nf
12264       real(kind=8) :: xi,aincr,etot,etot1,etot2
12265       call zerograd
12266       aincr=1.0D-7
12267       print '(a)','Calling CHECK_INT.'
12268       nf=0
12269       nfl=0
12270       icg=1
12271       call geom_to_var(nvar,x)
12272       call var_to_geom(nvar,x)
12273       call chainbuild
12274       icall=1
12275 !      print *,'ICG=',ICG
12276       call etotal(energia)
12277       etot = energia(0)
12278 !el      call enerprint(energia)
12279 !      print *,'ICG=',ICG
12280 #ifdef MPL
12281       if (MyID.ne.BossID) then
12282         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12283         nf=x(nvar+1)
12284         nfl=x(nvar+2)
12285         icg=x(nvar+3)
12286       endif
12287 #endif
12288       nf=1
12289       nfl=3
12290 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12291       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12292 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12293       icall=1
12294       do i=1,nvar
12295         xi=x(i)
12296         x(i)=xi-0.5D0*aincr
12297         call var_to_geom(nvar,x)
12298         call chainbuild
12299         call etotal(energia1)
12300         etot1=energia1(0)
12301         x(i)=xi+0.5D0*aincr
12302         call var_to_geom(nvar,x)
12303         call chainbuild
12304         call etotal(energia2)
12305         etot2=energia2(0)
12306         gg(i)=(etot2-etot1)/aincr
12307         write (iout,*) i,etot1,etot2
12308         x(i)=xi
12309       enddo
12310       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12311           '     RelDiff*100% '
12312       do i=1,nvar
12313         if (i.le.nphi) then
12314           ii=i
12315           key = ' phi'
12316         else if (i.le.nphi+ntheta) then
12317           ii=i-nphi
12318           key=' theta'
12319         else if (i.le.nphi+ntheta+nside) then
12320            ii=i-(nphi+ntheta)
12321            key=' alpha'
12322         else
12323            ii=i-(nphi+ntheta+nside)
12324            key=' omega'
12325         endif
12326         write (iout,'(i3,a,i3,3(1pd16.6))') &
12327        i,key,ii,gg(i),gana(i),&
12328        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12329       enddo
12330       return
12331       end subroutine check_eint
12332 !-----------------------------------------------------------------------------
12333 ! econstr_local.F
12334 !-----------------------------------------------------------------------------
12335       subroutine Econstr_back
12336 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12337 !      implicit real*8 (a-h,o-z)
12338 !      include 'DIMENSIONS'
12339 !      include 'COMMON.CONTROL'
12340 !      include 'COMMON.VAR'
12341 !      include 'COMMON.MD'
12342       use MD_data
12343 !#ifndef LANG0
12344 !      include 'COMMON.LANGEVIN'
12345 !#else
12346 !      include 'COMMON.LANGEVIN.lang0'
12347 !#endif
12348 !      include 'COMMON.CHAIN'
12349 !      include 'COMMON.DERIV'
12350 !      include 'COMMON.GEO'
12351 !      include 'COMMON.LOCAL'
12352 !      include 'COMMON.INTERACT'
12353 !      include 'COMMON.IOUNITS'
12354 !      include 'COMMON.NAMES'
12355 !      include 'COMMON.TIME1'
12356       integer :: i,j,ii,k
12357       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12358
12359       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12360       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12361       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12362
12363       Uconst_back=0.0d0
12364       do i=1,nres
12365         dutheta(i)=0.0d0
12366         dugamma(i)=0.0d0
12367         do j=1,3
12368           duscdiff(j,i)=0.0d0
12369           duscdiffx(j,i)=0.0d0
12370         enddo
12371       enddo
12372       do i=1,nfrag_back
12373         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12374 !
12375 ! Deviations from theta angles
12376 !
12377         utheta_i=0.0d0
12378         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12379           dtheta_i=theta(j)-thetaref(j)
12380           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12381           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12382         enddo
12383         utheta(i)=utheta_i/(ii-1)
12384 !
12385 ! Deviations from gamma angles
12386 !
12387         ugamma_i=0.0d0
12388         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12389           dgamma_i=pinorm(phi(j)-phiref(j))
12390 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12391           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12392           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12393 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12394         enddo
12395         ugamma(i)=ugamma_i/(ii-2)
12396 !
12397 ! Deviations from local SC geometry
12398 !
12399         uscdiff(i)=0.0d0
12400         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12401           dxx=xxtab(j)-xxref(j)
12402           dyy=yytab(j)-yyref(j)
12403           dzz=zztab(j)-zzref(j)
12404           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12405           do k=1,3
12406             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12407              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12408              (ii-1)
12409             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12410              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12411              (ii-1)
12412             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12413            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12414             /(ii-1)
12415           enddo
12416 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12417 !     &      xxref(j),yyref(j),zzref(j)
12418         enddo
12419         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12420 !        write (iout,*) i," uscdiff",uscdiff(i)
12421 !
12422 ! Put together deviations from local geometry
12423 !
12424         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12425           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12426 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12427 !     &   " uconst_back",uconst_back
12428         utheta(i)=dsqrt(utheta(i))
12429         ugamma(i)=dsqrt(ugamma(i))
12430         uscdiff(i)=dsqrt(uscdiff(i))
12431       enddo
12432       return
12433       end subroutine Econstr_back
12434 !-----------------------------------------------------------------------------
12435 ! energy_p_new-sep_barrier.F
12436 !-----------------------------------------------------------------------------
12437       real(kind=8) function sscale(r)
12438 !      include "COMMON.SPLITELE"
12439       real(kind=8) :: r,gamm
12440       if(r.lt.r_cut-rlamb) then
12441         sscale=1.0d0
12442       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12443         gamm=(r-(r_cut-rlamb))/rlamb
12444         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12445       else
12446         sscale=0d0
12447       endif
12448       return
12449       end function sscale
12450       real(kind=8) function sscale_grad(r)
12451 !      include "COMMON.SPLITELE"
12452       real(kind=8) :: r,gamm
12453       if(r.lt.r_cut-rlamb) then
12454         sscale_grad=0.0d0
12455       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12456         gamm=(r-(r_cut-rlamb))/rlamb
12457         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12458       else
12459         sscale_grad=0d0
12460       endif
12461       return
12462       end function sscale_grad
12463
12464 !!!!!!!!!! PBCSCALE
12465       real(kind=8) function sscale_ele(r)
12466 !      include "COMMON.SPLITELE"
12467       real(kind=8) :: r,gamm
12468       if(r.lt.r_cut_ele-rlamb_ele) then
12469         sscale_ele=1.0d0
12470       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12471         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12472         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12473       else
12474         sscale_ele=0d0
12475       endif
12476       return
12477       end function sscale_ele
12478
12479       real(kind=8)  function sscagrad_ele(r)
12480       real(kind=8) :: r,gamm
12481 !      include "COMMON.SPLITELE"
12482       if(r.lt.r_cut_ele-rlamb_ele) then
12483         sscagrad_ele=0.0d0
12484       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12485         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12486         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12487       else
12488         sscagrad_ele=0.0d0
12489       endif
12490       return
12491       end function sscagrad_ele
12492       real(kind=8) function sscalelip(r)
12493       real(kind=8) r,gamm
12494         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12495       return
12496       end function sscalelip
12497 !C-----------------------------------------------------------------------
12498       real(kind=8) function sscagradlip(r)
12499       real(kind=8) r,gamm
12500         sscagradlip=r*(6.0d0*r-6.0d0)
12501       return
12502       end function sscagradlip
12503
12504 !!!!!!!!!!!!!!!
12505 !-----------------------------------------------------------------------------
12506       subroutine elj_long(evdw)
12507 !
12508 ! This subroutine calculates the interaction energy of nonbonded side chains
12509 ! assuming the LJ potential of interaction.
12510 !
12511 !      implicit real*8 (a-h,o-z)
12512 !      include 'DIMENSIONS'
12513 !      include 'COMMON.GEO'
12514 !      include 'COMMON.VAR'
12515 !      include 'COMMON.LOCAL'
12516 !      include 'COMMON.CHAIN'
12517 !      include 'COMMON.DERIV'
12518 !      include 'COMMON.INTERACT'
12519 !      include 'COMMON.TORSION'
12520 !      include 'COMMON.SBRIDGE'
12521 !      include 'COMMON.NAMES'
12522 !      include 'COMMON.IOUNITS'
12523 !      include 'COMMON.CONTACTS'
12524       real(kind=8),parameter :: accur=1.0d-10
12525       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12526 !el local variables
12527       integer :: i,iint,j,k,itypi,itypi1,itypj
12528       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12529       real(kind=8) :: e1,e2,evdwij,evdw
12530 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12531       evdw=0.0D0
12532       do i=iatsc_s,iatsc_e
12533         itypi=itype(i,1)
12534         if (itypi.eq.ntyp1) cycle
12535         itypi1=itype(i+1,1)
12536         xi=c(1,nres+i)
12537         yi=c(2,nres+i)
12538         zi=c(3,nres+i)
12539 !
12540 ! Calculate SC interaction energy.
12541 !
12542         do iint=1,nint_gr(i)
12543 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12544 !d   &                  'iend=',iend(i,iint)
12545           do j=istart(i,iint),iend(i,iint)
12546             itypj=itype(j,1)
12547             if (itypj.eq.ntyp1) cycle
12548             xj=c(1,nres+j)-xi
12549             yj=c(2,nres+j)-yi
12550             zj=c(3,nres+j)-zi
12551             rij=xj*xj+yj*yj+zj*zj
12552             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12553             if (sss.lt.1.0d0) then
12554               rrij=1.0D0/rij
12555               eps0ij=eps(itypi,itypj)
12556               fac=rrij**expon2
12557               e1=fac*fac*aa_aq(itypi,itypj)
12558               e2=fac*bb_aq(itypi,itypj)
12559               evdwij=e1+e2
12560               evdw=evdw+(1.0d0-sss)*evdwij
12561 !
12562 ! Calculate the components of the gradient in DC and X
12563 !
12564               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12565               gg(1)=xj*fac
12566               gg(2)=yj*fac
12567               gg(3)=zj*fac
12568               do k=1,3
12569                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12570                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12571                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12572                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12573               enddo
12574             endif
12575           enddo      ! j
12576         enddo        ! iint
12577       enddo          ! i
12578       do i=1,nct
12579         do j=1,3
12580           gvdwc(j,i)=expon*gvdwc(j,i)
12581           gvdwx(j,i)=expon*gvdwx(j,i)
12582         enddo
12583       enddo
12584 !******************************************************************************
12585 !
12586 !                              N O T E !!!
12587 !
12588 ! To save time, the factor of EXPON has been extracted from ALL components
12589 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12590 ! use!
12591 !
12592 !******************************************************************************
12593       return
12594       end subroutine elj_long
12595 !-----------------------------------------------------------------------------
12596       subroutine elj_short(evdw)
12597 !
12598 ! This subroutine calculates the interaction energy of nonbonded side chains
12599 ! assuming the LJ potential of interaction.
12600 !
12601 !      implicit real*8 (a-h,o-z)
12602 !      include 'DIMENSIONS'
12603 !      include 'COMMON.GEO'
12604 !      include 'COMMON.VAR'
12605 !      include 'COMMON.LOCAL'
12606 !      include 'COMMON.CHAIN'
12607 !      include 'COMMON.DERIV'
12608 !      include 'COMMON.INTERACT'
12609 !      include 'COMMON.TORSION'
12610 !      include 'COMMON.SBRIDGE'
12611 !      include 'COMMON.NAMES'
12612 !      include 'COMMON.IOUNITS'
12613 !      include 'COMMON.CONTACTS'
12614       real(kind=8),parameter :: accur=1.0d-10
12615       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12616 !el local variables
12617       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12618       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12619       real(kind=8) :: e1,e2,evdwij,evdw
12620 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12621       evdw=0.0D0
12622       do i=iatsc_s,iatsc_e
12623         itypi=itype(i,1)
12624         if (itypi.eq.ntyp1) cycle
12625         itypi1=itype(i+1,1)
12626         xi=c(1,nres+i)
12627         yi=c(2,nres+i)
12628         zi=c(3,nres+i)
12629 ! Change 12/1/95
12630         num_conti=0
12631 !
12632 ! Calculate SC interaction energy.
12633 !
12634         do iint=1,nint_gr(i)
12635 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12636 !d   &                  'iend=',iend(i,iint)
12637           do j=istart(i,iint),iend(i,iint)
12638             itypj=itype(j,1)
12639             if (itypj.eq.ntyp1) cycle
12640             xj=c(1,nres+j)-xi
12641             yj=c(2,nres+j)-yi
12642             zj=c(3,nres+j)-zi
12643 ! Change 12/1/95 to calculate four-body interactions
12644             rij=xj*xj+yj*yj+zj*zj
12645             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12646             if (sss.gt.0.0d0) then
12647               rrij=1.0D0/rij
12648               eps0ij=eps(itypi,itypj)
12649               fac=rrij**expon2
12650               e1=fac*fac*aa_aq(itypi,itypj)
12651               e2=fac*bb_aq(itypi,itypj)
12652               evdwij=e1+e2
12653               evdw=evdw+sss*evdwij
12654 !
12655 ! Calculate the components of the gradient in DC and X
12656 !
12657               fac=-rrij*(e1+evdwij)*sss
12658               gg(1)=xj*fac
12659               gg(2)=yj*fac
12660               gg(3)=zj*fac
12661               do k=1,3
12662                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12663                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12664                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12665                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12666               enddo
12667             endif
12668           enddo      ! j
12669         enddo        ! iint
12670       enddo          ! i
12671       do i=1,nct
12672         do j=1,3
12673           gvdwc(j,i)=expon*gvdwc(j,i)
12674           gvdwx(j,i)=expon*gvdwx(j,i)
12675         enddo
12676       enddo
12677 !******************************************************************************
12678 !
12679 !                              N O T E !!!
12680 !
12681 ! To save time, the factor of EXPON has been extracted from ALL components
12682 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12683 ! use!
12684 !
12685 !******************************************************************************
12686       return
12687       end subroutine elj_short
12688 !-----------------------------------------------------------------------------
12689       subroutine eljk_long(evdw)
12690 !
12691 ! This subroutine calculates the interaction energy of nonbonded side chains
12692 ! assuming the LJK potential of interaction.
12693 !
12694 !      implicit real*8 (a-h,o-z)
12695 !      include 'DIMENSIONS'
12696 !      include 'COMMON.GEO'
12697 !      include 'COMMON.VAR'
12698 !      include 'COMMON.LOCAL'
12699 !      include 'COMMON.CHAIN'
12700 !      include 'COMMON.DERIV'
12701 !      include 'COMMON.INTERACT'
12702 !      include 'COMMON.IOUNITS'
12703 !      include 'COMMON.NAMES'
12704       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12705       logical :: scheck
12706 !el local variables
12707       integer :: i,iint,j,k,itypi,itypi1,itypj
12708       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12709                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12710 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12711       evdw=0.0D0
12712       do i=iatsc_s,iatsc_e
12713         itypi=itype(i,1)
12714         if (itypi.eq.ntyp1) cycle
12715         itypi1=itype(i+1,1)
12716         xi=c(1,nres+i)
12717         yi=c(2,nres+i)
12718         zi=c(3,nres+i)
12719 !
12720 ! Calculate SC interaction energy.
12721 !
12722         do iint=1,nint_gr(i)
12723           do j=istart(i,iint),iend(i,iint)
12724             itypj=itype(j,1)
12725             if (itypj.eq.ntyp1) cycle
12726             xj=c(1,nres+j)-xi
12727             yj=c(2,nres+j)-yi
12728             zj=c(3,nres+j)-zi
12729             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12730             fac_augm=rrij**expon
12731             e_augm=augm(itypi,itypj)*fac_augm
12732             r_inv_ij=dsqrt(rrij)
12733             rij=1.0D0/r_inv_ij
12734             sss=sscale(rij/sigma(itypi,itypj))
12735             if (sss.lt.1.0d0) then
12736               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12737               fac=r_shift_inv**expon
12738               e1=fac*fac*aa_aq(itypi,itypj)
12739               e2=fac*bb_aq(itypi,itypj)
12740               evdwij=e_augm+e1+e2
12741 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12742 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12743 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12744 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12745 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12746 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12747 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12748               evdw=evdw+(1.0d0-sss)*evdwij
12749 !
12750 ! Calculate the components of the gradient in DC and X
12751 !
12752               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12753               fac=fac*(1.0d0-sss)
12754               gg(1)=xj*fac
12755               gg(2)=yj*fac
12756               gg(3)=zj*fac
12757               do k=1,3
12758                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12759                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12760                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12761                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12762               enddo
12763             endif
12764           enddo      ! j
12765         enddo        ! iint
12766       enddo          ! i
12767       do i=1,nct
12768         do j=1,3
12769           gvdwc(j,i)=expon*gvdwc(j,i)
12770           gvdwx(j,i)=expon*gvdwx(j,i)
12771         enddo
12772       enddo
12773       return
12774       end subroutine eljk_long
12775 !-----------------------------------------------------------------------------
12776       subroutine eljk_short(evdw)
12777 !
12778 ! This subroutine calculates the interaction energy of nonbonded side chains
12779 ! assuming the LJK potential of interaction.
12780 !
12781 !      implicit real*8 (a-h,o-z)
12782 !      include 'DIMENSIONS'
12783 !      include 'COMMON.GEO'
12784 !      include 'COMMON.VAR'
12785 !      include 'COMMON.LOCAL'
12786 !      include 'COMMON.CHAIN'
12787 !      include 'COMMON.DERIV'
12788 !      include 'COMMON.INTERACT'
12789 !      include 'COMMON.IOUNITS'
12790 !      include 'COMMON.NAMES'
12791       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12792       logical :: scheck
12793 !el local variables
12794       integer :: i,iint,j,k,itypi,itypi1,itypj
12795       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12796                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12797 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12798       evdw=0.0D0
12799       do i=iatsc_s,iatsc_e
12800         itypi=itype(i,1)
12801         if (itypi.eq.ntyp1) cycle
12802         itypi1=itype(i+1,1)
12803         xi=c(1,nres+i)
12804         yi=c(2,nres+i)
12805         zi=c(3,nres+i)
12806 !
12807 ! Calculate SC interaction energy.
12808 !
12809         do iint=1,nint_gr(i)
12810           do j=istart(i,iint),iend(i,iint)
12811             itypj=itype(j,1)
12812             if (itypj.eq.ntyp1) cycle
12813             xj=c(1,nres+j)-xi
12814             yj=c(2,nres+j)-yi
12815             zj=c(3,nres+j)-zi
12816             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12817             fac_augm=rrij**expon
12818             e_augm=augm(itypi,itypj)*fac_augm
12819             r_inv_ij=dsqrt(rrij)
12820             rij=1.0D0/r_inv_ij
12821             sss=sscale(rij/sigma(itypi,itypj))
12822             if (sss.gt.0.0d0) then
12823               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12824               fac=r_shift_inv**expon
12825               e1=fac*fac*aa_aq(itypi,itypj)
12826               e2=fac*bb_aq(itypi,itypj)
12827               evdwij=e_augm+e1+e2
12828 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12829 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12830 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12831 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12832 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12833 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12834 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12835               evdw=evdw+sss*evdwij
12836 !
12837 ! Calculate the components of the gradient in DC and X
12838 !
12839               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12840               fac=fac*sss
12841               gg(1)=xj*fac
12842               gg(2)=yj*fac
12843               gg(3)=zj*fac
12844               do k=1,3
12845                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12846                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12847                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12848                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12849               enddo
12850             endif
12851           enddo      ! j
12852         enddo        ! iint
12853       enddo          ! i
12854       do i=1,nct
12855         do j=1,3
12856           gvdwc(j,i)=expon*gvdwc(j,i)
12857           gvdwx(j,i)=expon*gvdwx(j,i)
12858         enddo
12859       enddo
12860       return
12861       end subroutine eljk_short
12862 !-----------------------------------------------------------------------------
12863       subroutine ebp_long(evdw)
12864 !
12865 ! This subroutine calculates the interaction energy of nonbonded side chains
12866 ! assuming the Berne-Pechukas potential of interaction.
12867 !
12868       use calc_data
12869 !      implicit real*8 (a-h,o-z)
12870 !      include 'DIMENSIONS'
12871 !      include 'COMMON.GEO'
12872 !      include 'COMMON.VAR'
12873 !      include 'COMMON.LOCAL'
12874 !      include 'COMMON.CHAIN'
12875 !      include 'COMMON.DERIV'
12876 !      include 'COMMON.NAMES'
12877 !      include 'COMMON.INTERACT'
12878 !      include 'COMMON.IOUNITS'
12879 !      include 'COMMON.CALC'
12880       use comm_srutu
12881 !el      integer :: icall
12882 !el      common /srutu/ icall
12883 !     double precision rrsave(maxdim)
12884       logical :: lprn
12885 !el local variables
12886       integer :: iint,itypi,itypi1,itypj
12887       real(kind=8) :: rrij,xi,yi,zi,fac
12888       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12889       evdw=0.0D0
12890 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12891       evdw=0.0D0
12892 !     if (icall.eq.0) then
12893 !       lprn=.true.
12894 !     else
12895         lprn=.false.
12896 !     endif
12897 !el      ind=0
12898       do i=iatsc_s,iatsc_e
12899         itypi=itype(i,1)
12900         if (itypi.eq.ntyp1) cycle
12901         itypi1=itype(i+1,1)
12902         xi=c(1,nres+i)
12903         yi=c(2,nres+i)
12904         zi=c(3,nres+i)
12905         dxi=dc_norm(1,nres+i)
12906         dyi=dc_norm(2,nres+i)
12907         dzi=dc_norm(3,nres+i)
12908 !        dsci_inv=dsc_inv(itypi)
12909         dsci_inv=vbld_inv(i+nres)
12910 !
12911 ! Calculate SC interaction energy.
12912 !
12913         do iint=1,nint_gr(i)
12914           do j=istart(i,iint),iend(i,iint)
12915 !el            ind=ind+1
12916             itypj=itype(j,1)
12917             if (itypj.eq.ntyp1) cycle
12918 !            dscj_inv=dsc_inv(itypj)
12919             dscj_inv=vbld_inv(j+nres)
12920             chi1=chi(itypi,itypj)
12921             chi2=chi(itypj,itypi)
12922             chi12=chi1*chi2
12923             chip1=chip(itypi)
12924             chip2=chip(itypj)
12925             chip12=chip1*chip2
12926             alf1=alp(itypi)
12927             alf2=alp(itypj)
12928             alf12=0.5D0*(alf1+alf2)
12929             xj=c(1,nres+j)-xi
12930             yj=c(2,nres+j)-yi
12931             zj=c(3,nres+j)-zi
12932             dxj=dc_norm(1,nres+j)
12933             dyj=dc_norm(2,nres+j)
12934             dzj=dc_norm(3,nres+j)
12935             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12936             rij=dsqrt(rrij)
12937             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12938
12939             if (sss.lt.1.0d0) then
12940
12941 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12942               call sc_angular
12943 ! Calculate whole angle-dependent part of epsilon and contributions
12944 ! to its derivatives
12945               fac=(rrij*sigsq)**expon2
12946               e1=fac*fac*aa_aq(itypi,itypj)
12947               e2=fac*bb_aq(itypi,itypj)
12948               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12949               eps2der=evdwij*eps3rt
12950               eps3der=evdwij*eps2rt
12951               evdwij=evdwij*eps2rt*eps3rt
12952               evdw=evdw+evdwij*(1.0d0-sss)
12953               if (lprn) then
12954               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12955               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12956 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12957 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12958 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12959 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12960 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12961 !d     &          evdwij
12962               endif
12963 ! Calculate gradient components.
12964               e1=e1*eps1*eps2rt**2*eps3rt**2
12965               fac=-expon*(e1+evdwij)
12966               sigder=fac/sigsq
12967               fac=rrij*fac
12968 ! Calculate radial part of the gradient
12969               gg(1)=xj*fac
12970               gg(2)=yj*fac
12971               gg(3)=zj*fac
12972 ! Calculate the angular part of the gradient and sum add the contributions
12973 ! to the appropriate components of the Cartesian gradient.
12974               call sc_grad_scale(1.0d0-sss)
12975             endif
12976           enddo      ! j
12977         enddo        ! iint
12978       enddo          ! i
12979 !     stop
12980       return
12981       end subroutine ebp_long
12982 !-----------------------------------------------------------------------------
12983       subroutine ebp_short(evdw)
12984 !
12985 ! This subroutine calculates the interaction energy of nonbonded side chains
12986 ! assuming the Berne-Pechukas potential of interaction.
12987 !
12988       use calc_data
12989 !      implicit real*8 (a-h,o-z)
12990 !      include 'DIMENSIONS'
12991 !      include 'COMMON.GEO'
12992 !      include 'COMMON.VAR'
12993 !      include 'COMMON.LOCAL'
12994 !      include 'COMMON.CHAIN'
12995 !      include 'COMMON.DERIV'
12996 !      include 'COMMON.NAMES'
12997 !      include 'COMMON.INTERACT'
12998 !      include 'COMMON.IOUNITS'
12999 !      include 'COMMON.CALC'
13000       use comm_srutu
13001 !el      integer :: icall
13002 !el      common /srutu/ icall
13003 !     double precision rrsave(maxdim)
13004       logical :: lprn
13005 !el local variables
13006       integer :: iint,itypi,itypi1,itypj
13007       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13008       real(kind=8) :: sss,e1,e2,evdw
13009       evdw=0.0D0
13010 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13011       evdw=0.0D0
13012 !     if (icall.eq.0) then
13013 !       lprn=.true.
13014 !     else
13015         lprn=.false.
13016 !     endif
13017 !el      ind=0
13018       do i=iatsc_s,iatsc_e
13019         itypi=itype(i,1)
13020         if (itypi.eq.ntyp1) cycle
13021         itypi1=itype(i+1,1)
13022         xi=c(1,nres+i)
13023         yi=c(2,nres+i)
13024         zi=c(3,nres+i)
13025         dxi=dc_norm(1,nres+i)
13026         dyi=dc_norm(2,nres+i)
13027         dzi=dc_norm(3,nres+i)
13028 !        dsci_inv=dsc_inv(itypi)
13029         dsci_inv=vbld_inv(i+nres)
13030 !
13031 ! Calculate SC interaction energy.
13032 !
13033         do iint=1,nint_gr(i)
13034           do j=istart(i,iint),iend(i,iint)
13035 !el            ind=ind+1
13036             itypj=itype(j,1)
13037             if (itypj.eq.ntyp1) cycle
13038 !            dscj_inv=dsc_inv(itypj)
13039             dscj_inv=vbld_inv(j+nres)
13040             chi1=chi(itypi,itypj)
13041             chi2=chi(itypj,itypi)
13042             chi12=chi1*chi2
13043             chip1=chip(itypi)
13044             chip2=chip(itypj)
13045             chip12=chip1*chip2
13046             alf1=alp(itypi)
13047             alf2=alp(itypj)
13048             alf12=0.5D0*(alf1+alf2)
13049             xj=c(1,nres+j)-xi
13050             yj=c(2,nres+j)-yi
13051             zj=c(3,nres+j)-zi
13052             dxj=dc_norm(1,nres+j)
13053             dyj=dc_norm(2,nres+j)
13054             dzj=dc_norm(3,nres+j)
13055             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13056             rij=dsqrt(rrij)
13057             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13058
13059             if (sss.gt.0.0d0) then
13060
13061 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13062               call sc_angular
13063 ! Calculate whole angle-dependent part of epsilon and contributions
13064 ! to its derivatives
13065               fac=(rrij*sigsq)**expon2
13066               e1=fac*fac*aa_aq(itypi,itypj)
13067               e2=fac*bb_aq(itypi,itypj)
13068               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13069               eps2der=evdwij*eps3rt
13070               eps3der=evdwij*eps2rt
13071               evdwij=evdwij*eps2rt*eps3rt
13072               evdw=evdw+evdwij*sss
13073               if (lprn) then
13074               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13075               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13076 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13077 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13078 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13079 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13080 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13081 !d     &          evdwij
13082               endif
13083 ! Calculate gradient components.
13084               e1=e1*eps1*eps2rt**2*eps3rt**2
13085               fac=-expon*(e1+evdwij)
13086               sigder=fac/sigsq
13087               fac=rrij*fac
13088 ! Calculate radial part of the gradient
13089               gg(1)=xj*fac
13090               gg(2)=yj*fac
13091               gg(3)=zj*fac
13092 ! Calculate the angular part of the gradient and sum add the contributions
13093 ! to the appropriate components of the Cartesian gradient.
13094               call sc_grad_scale(sss)
13095             endif
13096           enddo      ! j
13097         enddo        ! iint
13098       enddo          ! i
13099 !     stop
13100       return
13101       end subroutine ebp_short
13102 !-----------------------------------------------------------------------------
13103       subroutine egb_long(evdw)
13104 !
13105 ! This subroutine calculates the interaction energy of nonbonded side chains
13106 ! assuming the Gay-Berne potential of interaction.
13107 !
13108       use calc_data
13109 !      implicit real*8 (a-h,o-z)
13110 !      include 'DIMENSIONS'
13111 !      include 'COMMON.GEO'
13112 !      include 'COMMON.VAR'
13113 !      include 'COMMON.LOCAL'
13114 !      include 'COMMON.CHAIN'
13115 !      include 'COMMON.DERIV'
13116 !      include 'COMMON.NAMES'
13117 !      include 'COMMON.INTERACT'
13118 !      include 'COMMON.IOUNITS'
13119 !      include 'COMMON.CALC'
13120 !      include 'COMMON.CONTROL'
13121       logical :: lprn
13122 !el local variables
13123       integer :: iint,itypi,itypi1,itypj,subchap
13124       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13125       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13126       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13127                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13128                     ssgradlipi,ssgradlipj
13129
13130
13131       evdw=0.0D0
13132 !cccc      energy_dec=.false.
13133 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13134       evdw=0.0D0
13135       lprn=.false.
13136 !     if (icall.eq.0) lprn=.false.
13137 !el      ind=0
13138       do i=iatsc_s,iatsc_e
13139         itypi=itype(i,1)
13140         if (itypi.eq.ntyp1) cycle
13141         itypi1=itype(i+1,1)
13142         xi=c(1,nres+i)
13143         yi=c(2,nres+i)
13144         zi=c(3,nres+i)
13145           xi=mod(xi,boxxsize)
13146           if (xi.lt.0) xi=xi+boxxsize
13147           yi=mod(yi,boxysize)
13148           if (yi.lt.0) yi=yi+boxysize
13149           zi=mod(zi,boxzsize)
13150           if (zi.lt.0) zi=zi+boxzsize
13151        if ((zi.gt.bordlipbot)    &
13152         .and.(zi.lt.bordliptop)) then
13153 !C the energy transfer exist
13154         if (zi.lt.buflipbot) then
13155 !C what fraction I am in
13156          fracinbuf=1.0d0-    &
13157              ((zi-bordlipbot)/lipbufthick)
13158 !C lipbufthick is thickenes of lipid buffore
13159          sslipi=sscalelip(fracinbuf)
13160          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13161         elseif (zi.gt.bufliptop) then
13162          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13163          sslipi=sscalelip(fracinbuf)
13164          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13165         else
13166          sslipi=1.0d0
13167          ssgradlipi=0.0
13168         endif
13169        else
13170          sslipi=0.0d0
13171          ssgradlipi=0.0
13172        endif
13173
13174         dxi=dc_norm(1,nres+i)
13175         dyi=dc_norm(2,nres+i)
13176         dzi=dc_norm(3,nres+i)
13177 !        dsci_inv=dsc_inv(itypi)
13178         dsci_inv=vbld_inv(i+nres)
13179 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13180 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13181 !
13182 ! Calculate SC interaction energy.
13183 !
13184         do iint=1,nint_gr(i)
13185           do j=istart(i,iint),iend(i,iint)
13186             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13187 !              call dyn_ssbond_ene(i,j,evdwij)
13188 !              evdw=evdw+evdwij
13189 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13190 !                              'evdw',i,j,evdwij,' ss'
13191 !              if (energy_dec) write (iout,*) &
13192 !                              'evdw',i,j,evdwij,' ss'
13193 !             do k=j+1,iend(i,iint)
13194 !C search over all next residues
13195 !              if (dyn_ss_mask(k)) then
13196 !C check if they are cysteins
13197 !C              write(iout,*) 'k=',k
13198
13199 !c              write(iout,*) "PRZED TRI", evdwij
13200 !               evdwij_przed_tri=evdwij
13201 !              call triple_ssbond_ene(i,j,k,evdwij)
13202 !c               if(evdwij_przed_tri.ne.evdwij) then
13203 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13204 !c               endif
13205
13206 !c              write(iout,*) "PO TRI", evdwij
13207 !C call the energy function that removes the artifical triple disulfide
13208 !C bond the soubroutine is located in ssMD.F
13209 !              evdw=evdw+evdwij
13210               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13211                             'evdw',i,j,evdwij,'tss'
13212 !              endif!dyn_ss_mask(k)
13213 !             enddo! k
13214
13215             ELSE
13216 !el            ind=ind+1
13217             itypj=itype(j,1)
13218             if (itypj.eq.ntyp1) cycle
13219 !            dscj_inv=dsc_inv(itypj)
13220             dscj_inv=vbld_inv(j+nres)
13221 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13222 !     &       1.0d0/vbld(j+nres)
13223 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13224             sig0ij=sigma(itypi,itypj)
13225             chi1=chi(itypi,itypj)
13226             chi2=chi(itypj,itypi)
13227             chi12=chi1*chi2
13228             chip1=chip(itypi)
13229             chip2=chip(itypj)
13230             chip12=chip1*chip2
13231             alf1=alp(itypi)
13232             alf2=alp(itypj)
13233             alf12=0.5D0*(alf1+alf2)
13234             xj=c(1,nres+j)
13235             yj=c(2,nres+j)
13236             zj=c(3,nres+j)
13237 ! Searching for nearest neighbour
13238           xj=mod(xj,boxxsize)
13239           if (xj.lt.0) xj=xj+boxxsize
13240           yj=mod(yj,boxysize)
13241           if (yj.lt.0) yj=yj+boxysize
13242           zj=mod(zj,boxzsize)
13243           if (zj.lt.0) zj=zj+boxzsize
13244        if ((zj.gt.bordlipbot)   &
13245       .and.(zj.lt.bordliptop)) then
13246 !C the energy transfer exist
13247         if (zj.lt.buflipbot) then
13248 !C what fraction I am in
13249          fracinbuf=1.0d0-  &
13250              ((zj-bordlipbot)/lipbufthick)
13251 !C lipbufthick is thickenes of lipid buffore
13252          sslipj=sscalelip(fracinbuf)
13253          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13254         elseif (zj.gt.bufliptop) then
13255          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13256          sslipj=sscalelip(fracinbuf)
13257          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13258         else
13259          sslipj=1.0d0
13260          ssgradlipj=0.0
13261         endif
13262        else
13263          sslipj=0.0d0
13264          ssgradlipj=0.0
13265        endif
13266       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13267        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13268       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13269        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13270
13271           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13272           xj_safe=xj
13273           yj_safe=yj
13274           zj_safe=zj
13275           subchap=0
13276           do xshift=-1,1
13277           do yshift=-1,1
13278           do zshift=-1,1
13279           xj=xj_safe+xshift*boxxsize
13280           yj=yj_safe+yshift*boxysize
13281           zj=zj_safe+zshift*boxzsize
13282           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13283           if(dist_temp.lt.dist_init) then
13284             dist_init=dist_temp
13285             xj_temp=xj
13286             yj_temp=yj
13287             zj_temp=zj
13288             subchap=1
13289           endif
13290           enddo
13291           enddo
13292           enddo
13293           if (subchap.eq.1) then
13294           xj=xj_temp-xi
13295           yj=yj_temp-yi
13296           zj=zj_temp-zi
13297           else
13298           xj=xj_safe-xi
13299           yj=yj_safe-yi
13300           zj=zj_safe-zi
13301           endif
13302
13303             dxj=dc_norm(1,nres+j)
13304             dyj=dc_norm(2,nres+j)
13305             dzj=dc_norm(3,nres+j)
13306             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13307             rij=dsqrt(rrij)
13308             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13309             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13310             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13311             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13312             if (sss_ele_cut.le.0.0) cycle
13313             if (sss.lt.1.0d0) then
13314
13315 ! Calculate angle-dependent terms of energy and contributions to their
13316 ! derivatives.
13317               call sc_angular
13318               sigsq=1.0D0/sigsq
13319               sig=sig0ij*dsqrt(sigsq)
13320               rij_shift=1.0D0/rij-sig+sig0ij
13321 ! for diagnostics; uncomment
13322 !              rij_shift=1.2*sig0ij
13323 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13324               if (rij_shift.le.0.0D0) then
13325                 evdw=1.0D20
13326 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13327 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13328 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13329                 return
13330               endif
13331               sigder=-sig*sigsq
13332 !---------------------------------------------------------------
13333               rij_shift=1.0D0/rij_shift
13334               fac=rij_shift**expon
13335               e1=fac*fac*aa
13336               e2=fac*bb
13337               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13338               eps2der=evdwij*eps3rt
13339               eps3der=evdwij*eps2rt
13340 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13341 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13342               evdwij=evdwij*eps2rt*eps3rt
13343               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13344               if (lprn) then
13345               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13346               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13347               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13348                 restyp(itypi,1),i,restyp(itypj,1),j,&
13349                 epsi,sigm,chi1,chi2,chip1,chip2,&
13350                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13351                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13352                 evdwij
13353               endif
13354
13355               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13356                               'evdw',i,j,evdwij
13357 !              if (energy_dec) write (iout,*) &
13358 !                              'evdw',i,j,evdwij,"egb_long"
13359
13360 ! Calculate gradient components.
13361               e1=e1*eps1*eps2rt**2*eps3rt**2
13362               fac=-expon*(e1+evdwij)*rij_shift
13363               sigder=fac*sigder
13364               fac=rij*fac
13365               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13366             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13367             /sigmaii(itypi,itypj))
13368 !              fac=0.0d0
13369 ! Calculate the radial part of the gradient
13370               gg(1)=xj*fac
13371               gg(2)=yj*fac
13372               gg(3)=zj*fac
13373 ! Calculate angular part of the gradient.
13374               call sc_grad_scale(1.0d0-sss)
13375             ENDIF    !mask_dyn_ss
13376             endif
13377           enddo      ! j
13378         enddo        ! iint
13379       enddo          ! i
13380 !      write (iout,*) "Number of loop steps in EGB:",ind
13381 !ccc      energy_dec=.false.
13382       return
13383       end subroutine egb_long
13384 !-----------------------------------------------------------------------------
13385       subroutine egb_short(evdw)
13386 !
13387 ! This subroutine calculates the interaction energy of nonbonded side chains
13388 ! assuming the Gay-Berne potential of interaction.
13389 !
13390       use calc_data
13391 !      implicit real*8 (a-h,o-z)
13392 !      include 'DIMENSIONS'
13393 !      include 'COMMON.GEO'
13394 !      include 'COMMON.VAR'
13395 !      include 'COMMON.LOCAL'
13396 !      include 'COMMON.CHAIN'
13397 !      include 'COMMON.DERIV'
13398 !      include 'COMMON.NAMES'
13399 !      include 'COMMON.INTERACT'
13400 !      include 'COMMON.IOUNITS'
13401 !      include 'COMMON.CALC'
13402 !      include 'COMMON.CONTROL'
13403       logical :: lprn
13404 !el local variables
13405       integer :: iint,itypi,itypi1,itypj,subchap
13406       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13407       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13408       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13409                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13410                     ssgradlipi,ssgradlipj
13411       evdw=0.0D0
13412 !cccc      energy_dec=.false.
13413 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13414       evdw=0.0D0
13415       lprn=.false.
13416 !     if (icall.eq.0) lprn=.false.
13417 !el      ind=0
13418       do i=iatsc_s,iatsc_e
13419         itypi=itype(i,1)
13420         if (itypi.eq.ntyp1) cycle
13421         itypi1=itype(i+1,1)
13422         xi=c(1,nres+i)
13423         yi=c(2,nres+i)
13424         zi=c(3,nres+i)
13425           xi=mod(xi,boxxsize)
13426           if (xi.lt.0) xi=xi+boxxsize
13427           yi=mod(yi,boxysize)
13428           if (yi.lt.0) yi=yi+boxysize
13429           zi=mod(zi,boxzsize)
13430           if (zi.lt.0) zi=zi+boxzsize
13431        if ((zi.gt.bordlipbot)    &
13432         .and.(zi.lt.bordliptop)) then
13433 !C the energy transfer exist
13434         if (zi.lt.buflipbot) then
13435 !C what fraction I am in
13436          fracinbuf=1.0d0-    &
13437              ((zi-bordlipbot)/lipbufthick)
13438 !C lipbufthick is thickenes of lipid buffore
13439          sslipi=sscalelip(fracinbuf)
13440          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13441         elseif (zi.gt.bufliptop) then
13442          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13443          sslipi=sscalelip(fracinbuf)
13444          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13445         else
13446          sslipi=1.0d0
13447          ssgradlipi=0.0
13448         endif
13449        else
13450          sslipi=0.0d0
13451          ssgradlipi=0.0
13452        endif
13453
13454         dxi=dc_norm(1,nres+i)
13455         dyi=dc_norm(2,nres+i)
13456         dzi=dc_norm(3,nres+i)
13457 !        dsci_inv=dsc_inv(itypi)
13458         dsci_inv=vbld_inv(i+nres)
13459
13460         dxi=dc_norm(1,nres+i)
13461         dyi=dc_norm(2,nres+i)
13462         dzi=dc_norm(3,nres+i)
13463 !        dsci_inv=dsc_inv(itypi)
13464         dsci_inv=vbld_inv(i+nres)
13465 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13466 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13467 !
13468 ! Calculate SC interaction energy.
13469 !
13470         do iint=1,nint_gr(i)
13471           do j=istart(i,iint),iend(i,iint)
13472             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13473               call dyn_ssbond_ene(i,j,evdwij)
13474               evdw=evdw+evdwij
13475               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13476                               'evdw',i,j,evdwij,' ss'
13477              do k=j+1,iend(i,iint)
13478 !C search over all next residues
13479               if (dyn_ss_mask(k)) then
13480 !C check if they are cysteins
13481 !C              write(iout,*) 'k=',k
13482
13483 !c              write(iout,*) "PRZED TRI", evdwij
13484 !               evdwij_przed_tri=evdwij
13485               call triple_ssbond_ene(i,j,k,evdwij)
13486 !c               if(evdwij_przed_tri.ne.evdwij) then
13487 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13488 !c               endif
13489
13490 !c              write(iout,*) "PO TRI", evdwij
13491 !C call the energy function that removes the artifical triple disulfide
13492 !C bond the soubroutine is located in ssMD.F
13493               evdw=evdw+evdwij
13494               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13495                             'evdw',i,j,evdwij,'tss'
13496               endif!dyn_ss_mask(k)
13497              enddo! k
13498
13499 !              if (energy_dec) write (iout,*) &
13500 !                              'evdw',i,j,evdwij,' ss'
13501             ELSE
13502 !el            ind=ind+1
13503             itypj=itype(j,1)
13504             if (itypj.eq.ntyp1) cycle
13505 !            dscj_inv=dsc_inv(itypj)
13506             dscj_inv=vbld_inv(j+nres)
13507 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13508 !     &       1.0d0/vbld(j+nres)
13509 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13510             sig0ij=sigma(itypi,itypj)
13511             chi1=chi(itypi,itypj)
13512             chi2=chi(itypj,itypi)
13513             chi12=chi1*chi2
13514             chip1=chip(itypi)
13515             chip2=chip(itypj)
13516             chip12=chip1*chip2
13517             alf1=alp(itypi)
13518             alf2=alp(itypj)
13519             alf12=0.5D0*(alf1+alf2)
13520 !            xj=c(1,nres+j)-xi
13521 !            yj=c(2,nres+j)-yi
13522 !            zj=c(3,nres+j)-zi
13523             xj=c(1,nres+j)
13524             yj=c(2,nres+j)
13525             zj=c(3,nres+j)
13526 ! Searching for nearest neighbour
13527           xj=mod(xj,boxxsize)
13528           if (xj.lt.0) xj=xj+boxxsize
13529           yj=mod(yj,boxysize)
13530           if (yj.lt.0) yj=yj+boxysize
13531           zj=mod(zj,boxzsize)
13532           if (zj.lt.0) zj=zj+boxzsize
13533        if ((zj.gt.bordlipbot)   &
13534       .and.(zj.lt.bordliptop)) then
13535 !C the energy transfer exist
13536         if (zj.lt.buflipbot) then
13537 !C what fraction I am in
13538          fracinbuf=1.0d0-  &
13539              ((zj-bordlipbot)/lipbufthick)
13540 !C lipbufthick is thickenes of lipid buffore
13541          sslipj=sscalelip(fracinbuf)
13542          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13543         elseif (zj.gt.bufliptop) then
13544          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13545          sslipj=sscalelip(fracinbuf)
13546          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13547         else
13548          sslipj=1.0d0
13549          ssgradlipj=0.0
13550         endif
13551        else
13552          sslipj=0.0d0
13553          ssgradlipj=0.0
13554        endif
13555       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13556        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13557       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13558        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13559
13560           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13561           xj_safe=xj
13562           yj_safe=yj
13563           zj_safe=zj
13564           subchap=0
13565
13566           do xshift=-1,1
13567           do yshift=-1,1
13568           do zshift=-1,1
13569           xj=xj_safe+xshift*boxxsize
13570           yj=yj_safe+yshift*boxysize
13571           zj=zj_safe+zshift*boxzsize
13572           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13573           if(dist_temp.lt.dist_init) then
13574             dist_init=dist_temp
13575             xj_temp=xj
13576             yj_temp=yj
13577             zj_temp=zj
13578             subchap=1
13579           endif
13580           enddo
13581           enddo
13582           enddo
13583           if (subchap.eq.1) then
13584           xj=xj_temp-xi
13585           yj=yj_temp-yi
13586           zj=zj_temp-zi
13587           else
13588           xj=xj_safe-xi
13589           yj=yj_safe-yi
13590           zj=zj_safe-zi
13591           endif
13592
13593             dxj=dc_norm(1,nres+j)
13594             dyj=dc_norm(2,nres+j)
13595             dzj=dc_norm(3,nres+j)
13596             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13597             rij=dsqrt(rrij)
13598             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13599             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13600             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13601             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13602             if (sss_ele_cut.le.0.0) cycle
13603
13604             if (sss.gt.0.0d0) then
13605
13606 ! Calculate angle-dependent terms of energy and contributions to their
13607 ! derivatives.
13608               call sc_angular
13609               sigsq=1.0D0/sigsq
13610               sig=sig0ij*dsqrt(sigsq)
13611               rij_shift=1.0D0/rij-sig+sig0ij
13612 ! for diagnostics; uncomment
13613 !              rij_shift=1.2*sig0ij
13614 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13615               if (rij_shift.le.0.0D0) then
13616                 evdw=1.0D20
13617 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13618 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13619 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13620                 return
13621               endif
13622               sigder=-sig*sigsq
13623 !---------------------------------------------------------------
13624               rij_shift=1.0D0/rij_shift
13625               fac=rij_shift**expon
13626               e1=fac*fac*aa
13627               e2=fac*bb
13628               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13629               eps2der=evdwij*eps3rt
13630               eps3der=evdwij*eps2rt
13631 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13632 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13633               evdwij=evdwij*eps2rt*eps3rt
13634               evdw=evdw+evdwij*sss*sss_ele_cut
13635               if (lprn) then
13636               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13637               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13638               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13639                 restyp(itypi,1),i,restyp(itypj,1),j,&
13640                 epsi,sigm,chi1,chi2,chip1,chip2,&
13641                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13642                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13643                 evdwij
13644               endif
13645
13646               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13647                               'evdw',i,j,evdwij
13648 !              if (energy_dec) write (iout,*) &
13649 !                              'evdw',i,j,evdwij,"egb_short"
13650
13651 ! Calculate gradient components.
13652               e1=e1*eps1*eps2rt**2*eps3rt**2
13653               fac=-expon*(e1+evdwij)*rij_shift
13654               sigder=fac*sigder
13655               fac=rij*fac
13656               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13657             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13658             /sigmaii(itypi,itypj))
13659
13660 !              fac=0.0d0
13661 ! Calculate the radial part of the gradient
13662               gg(1)=xj*fac
13663               gg(2)=yj*fac
13664               gg(3)=zj*fac
13665 ! Calculate angular part of the gradient.
13666               call sc_grad_scale(sss)
13667             endif
13668           ENDIF !mask_dyn_ss
13669           enddo      ! j
13670         enddo        ! iint
13671       enddo          ! i
13672 !      write (iout,*) "Number of loop steps in EGB:",ind
13673 !ccc      energy_dec=.false.
13674       return
13675       end subroutine egb_short
13676 !-----------------------------------------------------------------------------
13677       subroutine egbv_long(evdw)
13678 !
13679 ! This subroutine calculates the interaction energy of nonbonded side chains
13680 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13681 !
13682       use calc_data
13683 !      implicit real*8 (a-h,o-z)
13684 !      include 'DIMENSIONS'
13685 !      include 'COMMON.GEO'
13686 !      include 'COMMON.VAR'
13687 !      include 'COMMON.LOCAL'
13688 !      include 'COMMON.CHAIN'
13689 !      include 'COMMON.DERIV'
13690 !      include 'COMMON.NAMES'
13691 !      include 'COMMON.INTERACT'
13692 !      include 'COMMON.IOUNITS'
13693 !      include 'COMMON.CALC'
13694       use comm_srutu
13695 !el      integer :: icall
13696 !el      common /srutu/ icall
13697       logical :: lprn
13698 !el local variables
13699       integer :: iint,itypi,itypi1,itypj
13700       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13701       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13702       evdw=0.0D0
13703 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13704       evdw=0.0D0
13705       lprn=.false.
13706 !     if (icall.eq.0) lprn=.true.
13707 !el      ind=0
13708       do i=iatsc_s,iatsc_e
13709         itypi=itype(i,1)
13710         if (itypi.eq.ntyp1) cycle
13711         itypi1=itype(i+1,1)
13712         xi=c(1,nres+i)
13713         yi=c(2,nres+i)
13714         zi=c(3,nres+i)
13715         dxi=dc_norm(1,nres+i)
13716         dyi=dc_norm(2,nres+i)
13717         dzi=dc_norm(3,nres+i)
13718 !        dsci_inv=dsc_inv(itypi)
13719         dsci_inv=vbld_inv(i+nres)
13720 !
13721 ! Calculate SC interaction energy.
13722 !
13723         do iint=1,nint_gr(i)
13724           do j=istart(i,iint),iend(i,iint)
13725 !el            ind=ind+1
13726             itypj=itype(j,1)
13727             if (itypj.eq.ntyp1) cycle
13728 !            dscj_inv=dsc_inv(itypj)
13729             dscj_inv=vbld_inv(j+nres)
13730             sig0ij=sigma(itypi,itypj)
13731             r0ij=r0(itypi,itypj)
13732             chi1=chi(itypi,itypj)
13733             chi2=chi(itypj,itypi)
13734             chi12=chi1*chi2
13735             chip1=chip(itypi)
13736             chip2=chip(itypj)
13737             chip12=chip1*chip2
13738             alf1=alp(itypi)
13739             alf2=alp(itypj)
13740             alf12=0.5D0*(alf1+alf2)
13741             xj=c(1,nres+j)-xi
13742             yj=c(2,nres+j)-yi
13743             zj=c(3,nres+j)-zi
13744             dxj=dc_norm(1,nres+j)
13745             dyj=dc_norm(2,nres+j)
13746             dzj=dc_norm(3,nres+j)
13747             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13748             rij=dsqrt(rrij)
13749
13750             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13751
13752             if (sss.lt.1.0d0) then
13753
13754 ! Calculate angle-dependent terms of energy and contributions to their
13755 ! derivatives.
13756               call sc_angular
13757               sigsq=1.0D0/sigsq
13758               sig=sig0ij*dsqrt(sigsq)
13759               rij_shift=1.0D0/rij-sig+r0ij
13760 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13761               if (rij_shift.le.0.0D0) then
13762                 evdw=1.0D20
13763                 return
13764               endif
13765               sigder=-sig*sigsq
13766 !---------------------------------------------------------------
13767               rij_shift=1.0D0/rij_shift
13768               fac=rij_shift**expon
13769               e1=fac*fac*aa_aq(itypi,itypj)
13770               e2=fac*bb_aq(itypi,itypj)
13771               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13772               eps2der=evdwij*eps3rt
13773               eps3der=evdwij*eps2rt
13774               fac_augm=rrij**expon
13775               e_augm=augm(itypi,itypj)*fac_augm
13776               evdwij=evdwij*eps2rt*eps3rt
13777               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13778               if (lprn) then
13779               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13780               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13781               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13782                 restyp(itypi,1),i,restyp(itypj,1),j,&
13783                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13784                 chi1,chi2,chip1,chip2,&
13785                 eps1,eps2rt**2,eps3rt**2,&
13786                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13787                 evdwij+e_augm
13788               endif
13789 ! Calculate gradient components.
13790               e1=e1*eps1*eps2rt**2*eps3rt**2
13791               fac=-expon*(e1+evdwij)*rij_shift
13792               sigder=fac*sigder
13793               fac=rij*fac-2*expon*rrij*e_augm
13794 ! Calculate the radial part of the gradient
13795               gg(1)=xj*fac
13796               gg(2)=yj*fac
13797               gg(3)=zj*fac
13798 ! Calculate angular part of the gradient.
13799               call sc_grad_scale(1.0d0-sss)
13800             endif
13801           enddo      ! j
13802         enddo        ! iint
13803       enddo          ! i
13804       end subroutine egbv_long
13805 !-----------------------------------------------------------------------------
13806       subroutine egbv_short(evdw)
13807 !
13808 ! This subroutine calculates the interaction energy of nonbonded side chains
13809 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13810 !
13811       use calc_data
13812 !      implicit real*8 (a-h,o-z)
13813 !      include 'DIMENSIONS'
13814 !      include 'COMMON.GEO'
13815 !      include 'COMMON.VAR'
13816 !      include 'COMMON.LOCAL'
13817 !      include 'COMMON.CHAIN'
13818 !      include 'COMMON.DERIV'
13819 !      include 'COMMON.NAMES'
13820 !      include 'COMMON.INTERACT'
13821 !      include 'COMMON.IOUNITS'
13822 !      include 'COMMON.CALC'
13823       use comm_srutu
13824 !el      integer :: icall
13825 !el      common /srutu/ icall
13826       logical :: lprn
13827 !el local variables
13828       integer :: iint,itypi,itypi1,itypj
13829       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13830       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13831       evdw=0.0D0
13832 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13833       evdw=0.0D0
13834       lprn=.false.
13835 !     if (icall.eq.0) lprn=.true.
13836 !el      ind=0
13837       do i=iatsc_s,iatsc_e
13838         itypi=itype(i,1)
13839         if (itypi.eq.ntyp1) cycle
13840         itypi1=itype(i+1,1)
13841         xi=c(1,nres+i)
13842         yi=c(2,nres+i)
13843         zi=c(3,nres+i)
13844         dxi=dc_norm(1,nres+i)
13845         dyi=dc_norm(2,nres+i)
13846         dzi=dc_norm(3,nres+i)
13847 !        dsci_inv=dsc_inv(itypi)
13848         dsci_inv=vbld_inv(i+nres)
13849 !
13850 ! Calculate SC interaction energy.
13851 !
13852         do iint=1,nint_gr(i)
13853           do j=istart(i,iint),iend(i,iint)
13854 !el            ind=ind+1
13855             itypj=itype(j,1)
13856             if (itypj.eq.ntyp1) cycle
13857 !            dscj_inv=dsc_inv(itypj)
13858             dscj_inv=vbld_inv(j+nres)
13859             sig0ij=sigma(itypi,itypj)
13860             r0ij=r0(itypi,itypj)
13861             chi1=chi(itypi,itypj)
13862             chi2=chi(itypj,itypi)
13863             chi12=chi1*chi2
13864             chip1=chip(itypi)
13865             chip2=chip(itypj)
13866             chip12=chip1*chip2
13867             alf1=alp(itypi)
13868             alf2=alp(itypj)
13869             alf12=0.5D0*(alf1+alf2)
13870             xj=c(1,nres+j)-xi
13871             yj=c(2,nres+j)-yi
13872             zj=c(3,nres+j)-zi
13873             dxj=dc_norm(1,nres+j)
13874             dyj=dc_norm(2,nres+j)
13875             dzj=dc_norm(3,nres+j)
13876             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13877             rij=dsqrt(rrij)
13878
13879             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13880
13881             if (sss.gt.0.0d0) then
13882
13883 ! Calculate angle-dependent terms of energy and contributions to their
13884 ! derivatives.
13885               call sc_angular
13886               sigsq=1.0D0/sigsq
13887               sig=sig0ij*dsqrt(sigsq)
13888               rij_shift=1.0D0/rij-sig+r0ij
13889 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13890               if (rij_shift.le.0.0D0) then
13891                 evdw=1.0D20
13892                 return
13893               endif
13894               sigder=-sig*sigsq
13895 !---------------------------------------------------------------
13896               rij_shift=1.0D0/rij_shift
13897               fac=rij_shift**expon
13898               e1=fac*fac*aa_aq(itypi,itypj)
13899               e2=fac*bb_aq(itypi,itypj)
13900               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13901               eps2der=evdwij*eps3rt
13902               eps3der=evdwij*eps2rt
13903               fac_augm=rrij**expon
13904               e_augm=augm(itypi,itypj)*fac_augm
13905               evdwij=evdwij*eps2rt*eps3rt
13906               evdw=evdw+(evdwij+e_augm)*sss
13907               if (lprn) then
13908               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13909               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13910               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13911                 restyp(itypi,1),i,restyp(itypj,1),j,&
13912                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13913                 chi1,chi2,chip1,chip2,&
13914                 eps1,eps2rt**2,eps3rt**2,&
13915                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13916                 evdwij+e_augm
13917               endif
13918 ! Calculate gradient components.
13919               e1=e1*eps1*eps2rt**2*eps3rt**2
13920               fac=-expon*(e1+evdwij)*rij_shift
13921               sigder=fac*sigder
13922               fac=rij*fac-2*expon*rrij*e_augm
13923 ! Calculate the radial part of the gradient
13924               gg(1)=xj*fac
13925               gg(2)=yj*fac
13926               gg(3)=zj*fac
13927 ! Calculate angular part of the gradient.
13928               call sc_grad_scale(sss)
13929             endif
13930           enddo      ! j
13931         enddo        ! iint
13932       enddo          ! i
13933       end subroutine egbv_short
13934 !-----------------------------------------------------------------------------
13935       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13936 !
13937 ! This subroutine calculates the average interaction energy and its gradient
13938 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13939 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13940 ! The potential depends both on the distance of peptide-group centers and on
13941 ! the orientation of the CA-CA virtual bonds.
13942 !
13943 !      implicit real*8 (a-h,o-z)
13944
13945       use comm_locel
13946 #ifdef MPI
13947       include 'mpif.h'
13948 #endif
13949 !      include 'DIMENSIONS'
13950 !      include 'COMMON.CONTROL'
13951 !      include 'COMMON.SETUP'
13952 !      include 'COMMON.IOUNITS'
13953 !      include 'COMMON.GEO'
13954 !      include 'COMMON.VAR'
13955 !      include 'COMMON.LOCAL'
13956 !      include 'COMMON.CHAIN'
13957 !      include 'COMMON.DERIV'
13958 !      include 'COMMON.INTERACT'
13959 !      include 'COMMON.CONTACTS'
13960 !      include 'COMMON.TORSION'
13961 !      include 'COMMON.VECTORS'
13962 !      include 'COMMON.FFIELD'
13963 !      include 'COMMON.TIME1'
13964       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13965       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13966       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13967 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13968       real(kind=8),dimension(4) :: muij
13969 !el      integer :: num_conti,j1,j2
13970 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13971 !el                   dz_normi,xmedi,ymedi,zmedi
13972 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13973 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13974 !el          num_conti,j1,j2
13975 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13976 #ifdef MOMENT
13977       real(kind=8) :: scal_el=1.0d0
13978 #else
13979       real(kind=8) :: scal_el=0.5d0
13980 #endif
13981 ! 12/13/98
13982 ! 13-go grudnia roku pamietnego...
13983       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13984                                              0.0d0,1.0d0,0.0d0,&
13985                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13986 !el local variables
13987       integer :: i,j,k
13988       real(kind=8) :: fac
13989       real(kind=8) :: dxj,dyj,dzj
13990       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13991
13992 !      allocate(num_cont_hb(nres)) !(maxres)
13993 !d      write(iout,*) 'In EELEC'
13994 !d      do i=1,nloctyp
13995 !d        write(iout,*) 'Type',i
13996 !d        write(iout,*) 'B1',B1(:,i)
13997 !d        write(iout,*) 'B2',B2(:,i)
13998 !d        write(iout,*) 'CC',CC(:,:,i)
13999 !d        write(iout,*) 'DD',DD(:,:,i)
14000 !d        write(iout,*) 'EE',EE(:,:,i)
14001 !d      enddo
14002 !d      call check_vecgrad
14003 !d      stop
14004       if (icheckgrad.eq.1) then
14005         do i=1,nres-1
14006           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14007           do k=1,3
14008             dc_norm(k,i)=dc(k,i)*fac
14009           enddo
14010 !          write (iout,*) 'i',i,' fac',fac
14011         enddo
14012       endif
14013       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14014           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14015           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14016 !        call vec_and_deriv
14017 #ifdef TIMING
14018         time01=MPI_Wtime()
14019 #endif
14020 !        print *, "before set matrices"
14021         call set_matrices
14022 !        print *,"after set martices"
14023 #ifdef TIMING
14024         time_mat=time_mat+MPI_Wtime()-time01
14025 #endif
14026       endif
14027 !d      do i=1,nres-1
14028 !d        write (iout,*) 'i=',i
14029 !d        do k=1,3
14030 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14031 !d        enddo
14032 !d        do k=1,3
14033 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14034 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14035 !d        enddo
14036 !d      enddo
14037       t_eelecij=0.0d0
14038       ees=0.0D0
14039       evdw1=0.0D0
14040       eel_loc=0.0d0
14041       eello_turn3=0.0d0
14042       eello_turn4=0.0d0
14043 !el      ind=0
14044       do i=1,nres
14045         num_cont_hb(i)=0
14046       enddo
14047 !d      print '(a)','Enter EELEC'
14048 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14049 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14050 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14051       do i=1,nres
14052         gel_loc_loc(i)=0.0d0
14053         gcorr_loc(i)=0.0d0
14054       enddo
14055 !
14056 !
14057 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14058 !
14059 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14060 !
14061       do i=iturn3_start,iturn3_end
14062         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14063         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14064         dxi=dc(1,i)
14065         dyi=dc(2,i)
14066         dzi=dc(3,i)
14067         dx_normi=dc_norm(1,i)
14068         dy_normi=dc_norm(2,i)
14069         dz_normi=dc_norm(3,i)
14070         xmedi=c(1,i)+0.5d0*dxi
14071         ymedi=c(2,i)+0.5d0*dyi
14072         zmedi=c(3,i)+0.5d0*dzi
14073           xmedi=dmod(xmedi,boxxsize)
14074           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14075           ymedi=dmod(ymedi,boxysize)
14076           if (ymedi.lt.0) ymedi=ymedi+boxysize
14077           zmedi=dmod(zmedi,boxzsize)
14078           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14079         num_conti=0
14080         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14081         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14082         num_cont_hb(i)=num_conti
14083       enddo
14084       do i=iturn4_start,iturn4_end
14085         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14086           .or. itype(i+3,1).eq.ntyp1 &
14087           .or. itype(i+4,1).eq.ntyp1) cycle
14088         dxi=dc(1,i)
14089         dyi=dc(2,i)
14090         dzi=dc(3,i)
14091         dx_normi=dc_norm(1,i)
14092         dy_normi=dc_norm(2,i)
14093         dz_normi=dc_norm(3,i)
14094         xmedi=c(1,i)+0.5d0*dxi
14095         ymedi=c(2,i)+0.5d0*dyi
14096         zmedi=c(3,i)+0.5d0*dzi
14097           xmedi=dmod(xmedi,boxxsize)
14098           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14099           ymedi=dmod(ymedi,boxysize)
14100           if (ymedi.lt.0) ymedi=ymedi+boxysize
14101           zmedi=dmod(zmedi,boxzsize)
14102           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14103         num_conti=num_cont_hb(i)
14104         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14105         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14106           call eturn4(i,eello_turn4)
14107         num_cont_hb(i)=num_conti
14108       enddo   ! i
14109 !
14110 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14111 !
14112       do i=iatel_s,iatel_e
14113         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14114         dxi=dc(1,i)
14115         dyi=dc(2,i)
14116         dzi=dc(3,i)
14117         dx_normi=dc_norm(1,i)
14118         dy_normi=dc_norm(2,i)
14119         dz_normi=dc_norm(3,i)
14120         xmedi=c(1,i)+0.5d0*dxi
14121         ymedi=c(2,i)+0.5d0*dyi
14122         zmedi=c(3,i)+0.5d0*dzi
14123           xmedi=dmod(xmedi,boxxsize)
14124           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14125           ymedi=dmod(ymedi,boxysize)
14126           if (ymedi.lt.0) ymedi=ymedi+boxysize
14127           zmedi=dmod(zmedi,boxzsize)
14128           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14129 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14130         num_conti=num_cont_hb(i)
14131         do j=ielstart(i),ielend(i)
14132           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14133           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14134         enddo ! j
14135         num_cont_hb(i)=num_conti
14136       enddo   ! i
14137 !      write (iout,*) "Number of loop steps in EELEC:",ind
14138 !d      do i=1,nres
14139 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14140 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14141 !d      enddo
14142 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14143 !cc      eel_loc=eel_loc+eello_turn3
14144 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14145       return
14146       end subroutine eelec_scale
14147 !-----------------------------------------------------------------------------
14148       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14149 !      implicit real*8 (a-h,o-z)
14150
14151       use comm_locel
14152 !      include 'DIMENSIONS'
14153 #ifdef MPI
14154       include "mpif.h"
14155 #endif
14156 !      include 'COMMON.CONTROL'
14157 !      include 'COMMON.IOUNITS'
14158 !      include 'COMMON.GEO'
14159 !      include 'COMMON.VAR'
14160 !      include 'COMMON.LOCAL'
14161 !      include 'COMMON.CHAIN'
14162 !      include 'COMMON.DERIV'
14163 !      include 'COMMON.INTERACT'
14164 !      include 'COMMON.CONTACTS'
14165 !      include 'COMMON.TORSION'
14166 !      include 'COMMON.VECTORS'
14167 !      include 'COMMON.FFIELD'
14168 !      include 'COMMON.TIME1'
14169       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14170       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14171       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14172 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14173       real(kind=8),dimension(4) :: muij
14174       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14175                     dist_temp, dist_init,sss_grad
14176       integer xshift,yshift,zshift
14177
14178 !el      integer :: num_conti,j1,j2
14179 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14180 !el                   dz_normi,xmedi,ymedi,zmedi
14181 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14182 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14183 !el          num_conti,j1,j2
14184 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14185 #ifdef MOMENT
14186       real(kind=8) :: scal_el=1.0d0
14187 #else
14188       real(kind=8) :: scal_el=0.5d0
14189 #endif
14190 ! 12/13/98
14191 ! 13-go grudnia roku pamietnego...
14192       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14193                                              0.0d0,1.0d0,0.0d0,&
14194                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14195 !el local variables
14196       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14197       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14198       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14199       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14200       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14201       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14202       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14203                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14204                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14205                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14206                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14207                   ecosam,ecosbm,ecosgm,ghalf,time00
14208 !      integer :: maxconts
14209 !      maxconts = nres/4
14210 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14211 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14212 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14213 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14214 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14215 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14216 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14217 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14218 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14219 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14220 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14221 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14222 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14223
14224 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14225 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14226
14227 #ifdef MPI
14228           time00=MPI_Wtime()
14229 #endif
14230 !d      write (iout,*) "eelecij",i,j
14231 !el          ind=ind+1
14232           iteli=itel(i)
14233           itelj=itel(j)
14234           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14235           aaa=app(iteli,itelj)
14236           bbb=bpp(iteli,itelj)
14237           ael6i=ael6(iteli,itelj)
14238           ael3i=ael3(iteli,itelj)
14239           dxj=dc(1,j)
14240           dyj=dc(2,j)
14241           dzj=dc(3,j)
14242           dx_normj=dc_norm(1,j)
14243           dy_normj=dc_norm(2,j)
14244           dz_normj=dc_norm(3,j)
14245 !          xj=c(1,j)+0.5D0*dxj-xmedi
14246 !          yj=c(2,j)+0.5D0*dyj-ymedi
14247 !          zj=c(3,j)+0.5D0*dzj-zmedi
14248           xj=c(1,j)+0.5D0*dxj
14249           yj=c(2,j)+0.5D0*dyj
14250           zj=c(3,j)+0.5D0*dzj
14251           xj=mod(xj,boxxsize)
14252           if (xj.lt.0) xj=xj+boxxsize
14253           yj=mod(yj,boxysize)
14254           if (yj.lt.0) yj=yj+boxysize
14255           zj=mod(zj,boxzsize)
14256           if (zj.lt.0) zj=zj+boxzsize
14257       isubchap=0
14258       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14259       xj_safe=xj
14260       yj_safe=yj
14261       zj_safe=zj
14262       do xshift=-1,1
14263       do yshift=-1,1
14264       do zshift=-1,1
14265           xj=xj_safe+xshift*boxxsize
14266           yj=yj_safe+yshift*boxysize
14267           zj=zj_safe+zshift*boxzsize
14268           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14269           if(dist_temp.lt.dist_init) then
14270             dist_init=dist_temp
14271             xj_temp=xj
14272             yj_temp=yj
14273             zj_temp=zj
14274             isubchap=1
14275           endif
14276        enddo
14277        enddo
14278        enddo
14279        if (isubchap.eq.1) then
14280 !C          print *,i,j
14281           xj=xj_temp-xmedi
14282           yj=yj_temp-ymedi
14283           zj=zj_temp-zmedi
14284        else
14285           xj=xj_safe-xmedi
14286           yj=yj_safe-ymedi
14287           zj=zj_safe-zmedi
14288        endif
14289
14290           rij=xj*xj+yj*yj+zj*zj
14291           rrmij=1.0D0/rij
14292           rij=dsqrt(rij)
14293           rmij=1.0D0/rij
14294 ! For extracting the short-range part of Evdwpp
14295           sss=sscale(rij/rpp(iteli,itelj))
14296             sss_ele_cut=sscale_ele(rij)
14297             sss_ele_grad=sscagrad_ele(rij)
14298             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14299 !             sss_ele_cut=1.0d0
14300 !             sss_ele_grad=0.0d0
14301             if (sss_ele_cut.le.0.0) go to 128
14302
14303           r3ij=rrmij*rmij
14304           r6ij=r3ij*r3ij
14305           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14306           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14307           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14308           fac=cosa-3.0D0*cosb*cosg
14309           ev1=aaa*r6ij*r6ij
14310 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14311           if (j.eq.i+2) ev1=scal_el*ev1
14312           ev2=bbb*r6ij
14313           fac3=ael6i*r6ij
14314           fac4=ael3i*r3ij
14315           evdwij=ev1+ev2
14316           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14317           el2=fac4*fac
14318           eesij=el1+el2
14319 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14320           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14321           ees=ees+eesij*sss_ele_cut
14322           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14323 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14324 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14325 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14326 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14327
14328           if (energy_dec) then
14329               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14330               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14331           endif
14332
14333 !
14334 ! Calculate contributions to the Cartesian gradient.
14335 !
14336 #ifdef SPLITELE
14337           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14338           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14339           fac1=fac
14340           erij(1)=xj*rmij
14341           erij(2)=yj*rmij
14342           erij(3)=zj*rmij
14343 !
14344 ! Radial derivatives. First process both termini of the fragment (i,j)
14345 !
14346           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14347           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14348           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14349 !          do k=1,3
14350 !            ghalf=0.5D0*ggg(k)
14351 !            gelc(k,i)=gelc(k,i)+ghalf
14352 !            gelc(k,j)=gelc(k,j)+ghalf
14353 !          enddo
14354 ! 9/28/08 AL Gradient compotents will be summed only at the end
14355           do k=1,3
14356             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14357             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14358           enddo
14359 !
14360 ! Loop over residues i+1 thru j-1.
14361 !
14362 !grad          do k=i+1,j-1
14363 !grad            do l=1,3
14364 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14365 !grad            enddo
14366 !grad          enddo
14367           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14368           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14369           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14370           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14371           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14372           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14373 !          do k=1,3
14374 !            ghalf=0.5D0*ggg(k)
14375 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14376 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14377 !          enddo
14378 ! 9/28/08 AL Gradient compotents will be summed only at the end
14379           do k=1,3
14380             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14381             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14382           enddo
14383 !
14384 ! Loop over residues i+1 thru j-1.
14385 !
14386 !grad          do k=i+1,j-1
14387 !grad            do l=1,3
14388 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14389 !grad            enddo
14390 !grad          enddo
14391 #else
14392           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14393           facel=(el1+eesij)*sss_ele_cut
14394           fac1=fac
14395           fac=-3*rrmij*(facvdw+facvdw+facel)
14396           erij(1)=xj*rmij
14397           erij(2)=yj*rmij
14398           erij(3)=zj*rmij
14399 !
14400 ! Radial derivatives. First process both termini of the fragment (i,j)
14401 !
14402           ggg(1)=fac*xj
14403           ggg(2)=fac*yj
14404           ggg(3)=fac*zj
14405 !          do k=1,3
14406 !            ghalf=0.5D0*ggg(k)
14407 !            gelc(k,i)=gelc(k,i)+ghalf
14408 !            gelc(k,j)=gelc(k,j)+ghalf
14409 !          enddo
14410 ! 9/28/08 AL Gradient compotents will be summed only at the end
14411           do k=1,3
14412             gelc_long(k,j)=gelc(k,j)+ggg(k)
14413             gelc_long(k,i)=gelc(k,i)-ggg(k)
14414           enddo
14415 !
14416 ! Loop over residues i+1 thru j-1.
14417 !
14418 !grad          do k=i+1,j-1
14419 !grad            do l=1,3
14420 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14421 !grad            enddo
14422 !grad          enddo
14423 ! 9/28/08 AL Gradient compotents will be summed only at the end
14424           ggg(1)=facvdw*xj
14425           ggg(2)=facvdw*yj
14426           ggg(3)=facvdw*zj
14427           do k=1,3
14428             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14429             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14430           enddo
14431 #endif
14432 !
14433 ! Angular part
14434 !
14435           ecosa=2.0D0*fac3*fac1+fac4
14436           fac4=-3.0D0*fac4
14437           fac3=-6.0D0*fac3
14438           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14439           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14440           do k=1,3
14441             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14442             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14443           enddo
14444 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14445 !d   &          (dcosg(k),k=1,3)
14446           do k=1,3
14447             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14448           enddo
14449 !          do k=1,3
14450 !            ghalf=0.5D0*ggg(k)
14451 !            gelc(k,i)=gelc(k,i)+ghalf
14452 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14453 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14454 !            gelc(k,j)=gelc(k,j)+ghalf
14455 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14456 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14457 !          enddo
14458 !grad          do k=i+1,j-1
14459 !grad            do l=1,3
14460 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14461 !grad            enddo
14462 !grad          enddo
14463           do k=1,3
14464             gelc(k,i)=gelc(k,i) &
14465                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14466                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14467                      *sss_ele_cut
14468             gelc(k,j)=gelc(k,j) &
14469                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14470                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14471                      *sss_ele_cut
14472             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14473             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14474           enddo
14475           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14476               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14477               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14478 !
14479 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14480 !   energy of a peptide unit is assumed in the form of a second-order
14481 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14482 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14483 !   are computed for EVERY pair of non-contiguous peptide groups.
14484 !
14485           if (j.lt.nres-1) then
14486             j1=j+1
14487             j2=j-1
14488           else
14489             j1=j-1
14490             j2=j-2
14491           endif
14492           kkk=0
14493           do k=1,2
14494             do l=1,2
14495               kkk=kkk+1
14496               muij(kkk)=mu(k,i)*mu(l,j)
14497             enddo
14498           enddo
14499 !d         write (iout,*) 'EELEC: i',i,' j',j
14500 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14501 !d          write(iout,*) 'muij',muij
14502           ury=scalar(uy(1,i),erij)
14503           urz=scalar(uz(1,i),erij)
14504           vry=scalar(uy(1,j),erij)
14505           vrz=scalar(uz(1,j),erij)
14506           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14507           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14508           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14509           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14510           fac=dsqrt(-ael6i)*r3ij
14511           a22=a22*fac
14512           a23=a23*fac
14513           a32=a32*fac
14514           a33=a33*fac
14515 !d          write (iout,'(4i5,4f10.5)')
14516 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14517 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14518 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14519 !d     &      uy(:,j),uz(:,j)
14520 !d          write (iout,'(4f10.5)')
14521 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14522 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14523 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14524 !d           write (iout,'(9f10.5/)')
14525 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14526 ! Derivatives of the elements of A in virtual-bond vectors
14527           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14528           do k=1,3
14529             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14530             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14531             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14532             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14533             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14534             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14535             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14536             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14537             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14538             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14539             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14540             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14541           enddo
14542 ! Compute radial contributions to the gradient
14543           facr=-3.0d0*rrmij
14544           a22der=a22*facr
14545           a23der=a23*facr
14546           a32der=a32*facr
14547           a33der=a33*facr
14548           agg(1,1)=a22der*xj
14549           agg(2,1)=a22der*yj
14550           agg(3,1)=a22der*zj
14551           agg(1,2)=a23der*xj
14552           agg(2,2)=a23der*yj
14553           agg(3,2)=a23der*zj
14554           agg(1,3)=a32der*xj
14555           agg(2,3)=a32der*yj
14556           agg(3,3)=a32der*zj
14557           agg(1,4)=a33der*xj
14558           agg(2,4)=a33der*yj
14559           agg(3,4)=a33der*zj
14560 ! Add the contributions coming from er
14561           fac3=-3.0d0*fac
14562           do k=1,3
14563             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14564             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14565             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14566             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14567           enddo
14568           do k=1,3
14569 ! Derivatives in DC(i)
14570 !grad            ghalf1=0.5d0*agg(k,1)
14571 !grad            ghalf2=0.5d0*agg(k,2)
14572 !grad            ghalf3=0.5d0*agg(k,3)
14573 !grad            ghalf4=0.5d0*agg(k,4)
14574             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14575             -3.0d0*uryg(k,2)*vry)!+ghalf1
14576             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14577             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14578             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14579             -3.0d0*urzg(k,2)*vry)!+ghalf3
14580             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14581             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14582 ! Derivatives in DC(i+1)
14583             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14584             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14585             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14586             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14587             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14588             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14589             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14590             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14591 ! Derivatives in DC(j)
14592             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14593             -3.0d0*vryg(k,2)*ury)!+ghalf1
14594             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14595             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14596             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14597             -3.0d0*vryg(k,2)*urz)!+ghalf3
14598             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14599             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14600 ! Derivatives in DC(j+1) or DC(nres-1)
14601             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14602             -3.0d0*vryg(k,3)*ury)
14603             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14604             -3.0d0*vrzg(k,3)*ury)
14605             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14606             -3.0d0*vryg(k,3)*urz)
14607             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14608             -3.0d0*vrzg(k,3)*urz)
14609 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14610 !grad              do l=1,4
14611 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14612 !grad              enddo
14613 !grad            endif
14614           enddo
14615           acipa(1,1)=a22
14616           acipa(1,2)=a23
14617           acipa(2,1)=a32
14618           acipa(2,2)=a33
14619           a22=-a22
14620           a23=-a23
14621           do l=1,2
14622             do k=1,3
14623               agg(k,l)=-agg(k,l)
14624               aggi(k,l)=-aggi(k,l)
14625               aggi1(k,l)=-aggi1(k,l)
14626               aggj(k,l)=-aggj(k,l)
14627               aggj1(k,l)=-aggj1(k,l)
14628             enddo
14629           enddo
14630           if (j.lt.nres-1) then
14631             a22=-a22
14632             a32=-a32
14633             do l=1,3,2
14634               do k=1,3
14635                 agg(k,l)=-agg(k,l)
14636                 aggi(k,l)=-aggi(k,l)
14637                 aggi1(k,l)=-aggi1(k,l)
14638                 aggj(k,l)=-aggj(k,l)
14639                 aggj1(k,l)=-aggj1(k,l)
14640               enddo
14641             enddo
14642           else
14643             a22=-a22
14644             a23=-a23
14645             a32=-a32
14646             a33=-a33
14647             do l=1,4
14648               do k=1,3
14649                 agg(k,l)=-agg(k,l)
14650                 aggi(k,l)=-aggi(k,l)
14651                 aggi1(k,l)=-aggi1(k,l)
14652                 aggj(k,l)=-aggj(k,l)
14653                 aggj1(k,l)=-aggj1(k,l)
14654               enddo
14655             enddo
14656           endif
14657           ENDIF ! WCORR
14658           IF (wel_loc.gt.0.0d0) THEN
14659 ! Contribution to the local-electrostatic energy coming from the i-j pair
14660           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14661            +a33*muij(4)
14662 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14663
14664           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14665                   'eelloc',i,j,eel_loc_ij
14666 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14667
14668           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14669 ! Partial derivatives in virtual-bond dihedral angles gamma
14670           if (i.gt.1) &
14671           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14672                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14673                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14674                  *sss_ele_cut
14675           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14676                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14677                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14678                  *sss_ele_cut
14679            xtemp(1)=xj
14680            xtemp(2)=yj
14681            xtemp(3)=zj
14682
14683 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14684           do l=1,3
14685             ggg(l)=(agg(l,1)*muij(1)+ &
14686                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14687             *sss_ele_cut &
14688              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14689
14690             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14691             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14692 !grad            ghalf=0.5d0*ggg(l)
14693 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14694 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14695           enddo
14696 !grad          do k=i+1,j2
14697 !grad            do l=1,3
14698 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14699 !grad            enddo
14700 !grad          enddo
14701 ! Remaining derivatives of eello
14702           do l=1,3
14703             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14704                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14705             *sss_ele_cut
14706
14707             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14708                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14709             *sss_ele_cut
14710
14711             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14712                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14713             *sss_ele_cut
14714
14715             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14716                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14717             *sss_ele_cut
14718
14719           enddo
14720           ENDIF
14721 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14722 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14723           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14724              .and. num_conti.le.maxconts) then
14725 !            write (iout,*) i,j," entered corr"
14726 !
14727 ! Calculate the contact function. The ith column of the array JCONT will
14728 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14729 ! greater than I). The arrays FACONT and GACONT will contain the values of
14730 ! the contact function and its derivative.
14731 !           r0ij=1.02D0*rpp(iteli,itelj)
14732 !           r0ij=1.11D0*rpp(iteli,itelj)
14733             r0ij=2.20D0*rpp(iteli,itelj)
14734 !           r0ij=1.55D0*rpp(iteli,itelj)
14735             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14736 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14737             if (fcont.gt.0.0D0) then
14738               num_conti=num_conti+1
14739               if (num_conti.gt.maxconts) then
14740 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14741                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14742                                ' will skip next contacts for this conf.',num_conti
14743               else
14744                 jcont_hb(num_conti,i)=j
14745 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14746 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14747                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14748                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14749 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14750 !  terms.
14751                 d_cont(num_conti,i)=rij
14752 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14753 !     --- Electrostatic-interaction matrix ---
14754                 a_chuj(1,1,num_conti,i)=a22
14755                 a_chuj(1,2,num_conti,i)=a23
14756                 a_chuj(2,1,num_conti,i)=a32
14757                 a_chuj(2,2,num_conti,i)=a33
14758 !     --- Gradient of rij
14759                 do kkk=1,3
14760                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14761                 enddo
14762                 kkll=0
14763                 do k=1,2
14764                   do l=1,2
14765                     kkll=kkll+1
14766                     do m=1,3
14767                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14768                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14769                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14770                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14771                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14772                     enddo
14773                   enddo
14774                 enddo
14775                 ENDIF
14776                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14777 ! Calculate contact energies
14778                 cosa4=4.0D0*cosa
14779                 wij=cosa-3.0D0*cosb*cosg
14780                 cosbg1=cosb+cosg
14781                 cosbg2=cosb-cosg
14782 !               fac3=dsqrt(-ael6i)/r0ij**3
14783                 fac3=dsqrt(-ael6i)*r3ij
14784 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14785                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14786                 if (ees0tmp.gt.0) then
14787                   ees0pij=dsqrt(ees0tmp)
14788                 else
14789                   ees0pij=0
14790                 endif
14791 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14792                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14793                 if (ees0tmp.gt.0) then
14794                   ees0mij=dsqrt(ees0tmp)
14795                 else
14796                   ees0mij=0
14797                 endif
14798 !               ees0mij=0.0D0
14799                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14800                      *sss_ele_cut
14801
14802                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14803                      *sss_ele_cut
14804
14805 ! Diagnostics. Comment out or remove after debugging!
14806 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14807 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14808 !               ees0m(num_conti,i)=0.0D0
14809 ! End diagnostics.
14810 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14811 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14812 ! Angular derivatives of the contact function
14813                 ees0pij1=fac3/ees0pij
14814                 ees0mij1=fac3/ees0mij
14815                 fac3p=-3.0D0*fac3*rrmij
14816                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14817                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14818 !               ees0mij1=0.0D0
14819                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14820                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14821                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14822                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14823                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14824                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14825                 ecosap=ecosa1+ecosa2
14826                 ecosbp=ecosb1+ecosb2
14827                 ecosgp=ecosg1+ecosg2
14828                 ecosam=ecosa1-ecosa2
14829                 ecosbm=ecosb1-ecosb2
14830                 ecosgm=ecosg1-ecosg2
14831 ! Diagnostics
14832 !               ecosap=ecosa1
14833 !               ecosbp=ecosb1
14834 !               ecosgp=ecosg1
14835 !               ecosam=0.0D0
14836 !               ecosbm=0.0D0
14837 !               ecosgm=0.0D0
14838 ! End diagnostics
14839                 facont_hb(num_conti,i)=fcont
14840                 fprimcont=fprimcont/rij
14841 !d              facont_hb(num_conti,i)=1.0D0
14842 ! Following line is for diagnostics.
14843 !d              fprimcont=0.0D0
14844                 do k=1,3
14845                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14846                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14847                 enddo
14848                 do k=1,3
14849                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14850                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14851                 enddo
14852 !                gggp(1)=gggp(1)+ees0pijp*xj
14853 !                gggp(2)=gggp(2)+ees0pijp*yj
14854 !                gggp(3)=gggp(3)+ees0pijp*zj
14855 !                gggm(1)=gggm(1)+ees0mijp*xj
14856 !                gggm(2)=gggm(2)+ees0mijp*yj
14857 !                gggm(3)=gggm(3)+ees0mijp*zj
14858                 gggp(1)=gggp(1)+ees0pijp*xj &
14859                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14860                 gggp(2)=gggp(2)+ees0pijp*yj &
14861                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14862                 gggp(3)=gggp(3)+ees0pijp*zj &
14863                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14864
14865                 gggm(1)=gggm(1)+ees0mijp*xj &
14866                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14867
14868                 gggm(2)=gggm(2)+ees0mijp*yj &
14869                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14870
14871                 gggm(3)=gggm(3)+ees0mijp*zj &
14872                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14873
14874 ! Derivatives due to the contact function
14875                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14876                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14877                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14878                 do k=1,3
14879 !
14880 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14881 !          following the change of gradient-summation algorithm.
14882 !
14883 !grad                  ghalfp=0.5D0*gggp(k)
14884 !grad                  ghalfm=0.5D0*gggm(k)
14885 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14886 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14887 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14888 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14889 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14890 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14891 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14892 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14893 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14894 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14895 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14896 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14897 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14898 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14899                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14900                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14901                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14902                      *sss_ele_cut
14903
14904                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14905                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14906                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14907                      *sss_ele_cut
14908
14909                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14910                      *sss_ele_cut
14911
14912                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14913                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14914                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14915                      *sss_ele_cut
14916
14917                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14918                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14919                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14920                      *sss_ele_cut
14921
14922                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14923                      *sss_ele_cut
14924
14925                 enddo
14926               ENDIF ! wcorr
14927               endif  ! num_conti.le.maxconts
14928             endif  ! fcont.gt.0
14929           endif    ! j.gt.i+1
14930           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14931             do k=1,4
14932               do l=1,3
14933                 ghalf=0.5d0*agg(l,k)
14934                 aggi(l,k)=aggi(l,k)+ghalf
14935                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14936                 aggj(l,k)=aggj(l,k)+ghalf
14937               enddo
14938             enddo
14939             if (j.eq.nres-1 .and. i.lt.j-2) then
14940               do k=1,4
14941                 do l=1,3
14942                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14943                 enddo
14944               enddo
14945             endif
14946           endif
14947  128      continue
14948 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14949       return
14950       end subroutine eelecij_scale
14951 !-----------------------------------------------------------------------------
14952       subroutine evdwpp_short(evdw1)
14953 !
14954 ! Compute Evdwpp
14955 !
14956 !      implicit real*8 (a-h,o-z)
14957 !      include 'DIMENSIONS'
14958 !      include 'COMMON.CONTROL'
14959 !      include 'COMMON.IOUNITS'
14960 !      include 'COMMON.GEO'
14961 !      include 'COMMON.VAR'
14962 !      include 'COMMON.LOCAL'
14963 !      include 'COMMON.CHAIN'
14964 !      include 'COMMON.DERIV'
14965 !      include 'COMMON.INTERACT'
14966 !      include 'COMMON.CONTACTS'
14967 !      include 'COMMON.TORSION'
14968 !      include 'COMMON.VECTORS'
14969 !      include 'COMMON.FFIELD'
14970       real(kind=8),dimension(3) :: ggg
14971 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14972 #ifdef MOMENT
14973       real(kind=8) :: scal_el=1.0d0
14974 #else
14975       real(kind=8) :: scal_el=0.5d0
14976 #endif
14977 !el local variables
14978       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14979       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14980       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14981                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14982                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14983       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14984                     dist_temp, dist_init,sss_grad
14985       integer xshift,yshift,zshift
14986
14987
14988       evdw1=0.0D0
14989 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14990 !     & " iatel_e_vdw",iatel_e_vdw
14991       call flush(iout)
14992       do i=iatel_s_vdw,iatel_e_vdw
14993         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14994         dxi=dc(1,i)
14995         dyi=dc(2,i)
14996         dzi=dc(3,i)
14997         dx_normi=dc_norm(1,i)
14998         dy_normi=dc_norm(2,i)
14999         dz_normi=dc_norm(3,i)
15000         xmedi=c(1,i)+0.5d0*dxi
15001         ymedi=c(2,i)+0.5d0*dyi
15002         zmedi=c(3,i)+0.5d0*dzi
15003           xmedi=dmod(xmedi,boxxsize)
15004           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15005           ymedi=dmod(ymedi,boxysize)
15006           if (ymedi.lt.0) ymedi=ymedi+boxysize
15007           zmedi=dmod(zmedi,boxzsize)
15008           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15009         num_conti=0
15010 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15011 !     &   ' ielend',ielend_vdw(i)
15012         call flush(iout)
15013         do j=ielstart_vdw(i),ielend_vdw(i)
15014           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15015 !el          ind=ind+1
15016           iteli=itel(i)
15017           itelj=itel(j)
15018           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15019           aaa=app(iteli,itelj)
15020           bbb=bpp(iteli,itelj)
15021           dxj=dc(1,j)
15022           dyj=dc(2,j)
15023           dzj=dc(3,j)
15024           dx_normj=dc_norm(1,j)
15025           dy_normj=dc_norm(2,j)
15026           dz_normj=dc_norm(3,j)
15027 !          xj=c(1,j)+0.5D0*dxj-xmedi
15028 !          yj=c(2,j)+0.5D0*dyj-ymedi
15029 !          zj=c(3,j)+0.5D0*dzj-zmedi
15030           xj=c(1,j)+0.5D0*dxj
15031           yj=c(2,j)+0.5D0*dyj
15032           zj=c(3,j)+0.5D0*dzj
15033           xj=mod(xj,boxxsize)
15034           if (xj.lt.0) xj=xj+boxxsize
15035           yj=mod(yj,boxysize)
15036           if (yj.lt.0) yj=yj+boxysize
15037           zj=mod(zj,boxzsize)
15038           if (zj.lt.0) zj=zj+boxzsize
15039       isubchap=0
15040       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15041       xj_safe=xj
15042       yj_safe=yj
15043       zj_safe=zj
15044       do xshift=-1,1
15045       do yshift=-1,1
15046       do zshift=-1,1
15047           xj=xj_safe+xshift*boxxsize
15048           yj=yj_safe+yshift*boxysize
15049           zj=zj_safe+zshift*boxzsize
15050           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15051           if(dist_temp.lt.dist_init) then
15052             dist_init=dist_temp
15053             xj_temp=xj
15054             yj_temp=yj
15055             zj_temp=zj
15056             isubchap=1
15057           endif
15058        enddo
15059        enddo
15060        enddo
15061        if (isubchap.eq.1) then
15062 !C          print *,i,j
15063           xj=xj_temp-xmedi
15064           yj=yj_temp-ymedi
15065           zj=zj_temp-zmedi
15066        else
15067           xj=xj_safe-xmedi
15068           yj=yj_safe-ymedi
15069           zj=zj_safe-zmedi
15070        endif
15071
15072           rij=xj*xj+yj*yj+zj*zj
15073           rrmij=1.0D0/rij
15074           rij=dsqrt(rij)
15075           sss=sscale(rij/rpp(iteli,itelj))
15076             sss_ele_cut=sscale_ele(rij)
15077             sss_ele_grad=sscagrad_ele(rij)
15078             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15079             if (sss_ele_cut.le.0.0) cycle
15080           if (sss.gt.0.0d0) then
15081             rmij=1.0D0/rij
15082             r3ij=rrmij*rmij
15083             r6ij=r3ij*r3ij
15084             ev1=aaa*r6ij*r6ij
15085 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15086             if (j.eq.i+2) ev1=scal_el*ev1
15087             ev2=bbb*r6ij
15088             evdwij=ev1+ev2
15089             if (energy_dec) then
15090               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15091             endif
15092             evdw1=evdw1+evdwij*sss*sss_ele_cut
15093 !
15094 ! Calculate contributions to the Cartesian gradient.
15095 !
15096             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15097 !            ggg(1)=facvdw*xj
15098 !            ggg(2)=facvdw*yj
15099 !            ggg(3)=facvdw*zj
15100           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15101           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15102           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15103           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15104           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15105           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15106
15107             do k=1,3
15108               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15109               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15110             enddo
15111           endif
15112         enddo ! j
15113       enddo   ! i
15114       return
15115       end subroutine evdwpp_short
15116 !-----------------------------------------------------------------------------
15117       subroutine escp_long(evdw2,evdw2_14)
15118 !
15119 ! This subroutine calculates the excluded-volume interaction energy between
15120 ! peptide-group centers and side chains and its gradient in virtual-bond and
15121 ! side-chain vectors.
15122 !
15123 !      implicit real*8 (a-h,o-z)
15124 !      include 'DIMENSIONS'
15125 !      include 'COMMON.GEO'
15126 !      include 'COMMON.VAR'
15127 !      include 'COMMON.LOCAL'
15128 !      include 'COMMON.CHAIN'
15129 !      include 'COMMON.DERIV'
15130 !      include 'COMMON.INTERACT'
15131 !      include 'COMMON.FFIELD'
15132 !      include 'COMMON.IOUNITS'
15133 !      include 'COMMON.CONTROL'
15134       real(kind=8),dimension(3) :: ggg
15135 !el local variables
15136       integer :: i,iint,j,k,iteli,itypj,subchap
15137       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15138       real(kind=8) :: evdw2,evdw2_14,evdwij
15139       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15140                     dist_temp, dist_init
15141
15142       evdw2=0.0D0
15143       evdw2_14=0.0d0
15144 !d    print '(a)','Enter ESCP'
15145 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15146       do i=iatscp_s,iatscp_e
15147         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15148         iteli=itel(i)
15149         xi=0.5D0*(c(1,i)+c(1,i+1))
15150         yi=0.5D0*(c(2,i)+c(2,i+1))
15151         zi=0.5D0*(c(3,i)+c(3,i+1))
15152           xi=mod(xi,boxxsize)
15153           if (xi.lt.0) xi=xi+boxxsize
15154           yi=mod(yi,boxysize)
15155           if (yi.lt.0) yi=yi+boxysize
15156           zi=mod(zi,boxzsize)
15157           if (zi.lt.0) zi=zi+boxzsize
15158
15159         do iint=1,nscp_gr(i)
15160
15161         do j=iscpstart(i,iint),iscpend(i,iint)
15162           itypj=itype(j,1)
15163           if (itypj.eq.ntyp1) cycle
15164 ! Uncomment following three lines for SC-p interactions
15165 !         xj=c(1,nres+j)-xi
15166 !         yj=c(2,nres+j)-yi
15167 !         zj=c(3,nres+j)-zi
15168 ! Uncomment following three lines for Ca-p interactions
15169           xj=c(1,j)
15170           yj=c(2,j)
15171           zj=c(3,j)
15172           xj=mod(xj,boxxsize)
15173           if (xj.lt.0) xj=xj+boxxsize
15174           yj=mod(yj,boxysize)
15175           if (yj.lt.0) yj=yj+boxysize
15176           zj=mod(zj,boxzsize)
15177           if (zj.lt.0) zj=zj+boxzsize
15178       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15179       xj_safe=xj
15180       yj_safe=yj
15181       zj_safe=zj
15182       subchap=0
15183       do xshift=-1,1
15184       do yshift=-1,1
15185       do zshift=-1,1
15186           xj=xj_safe+xshift*boxxsize
15187           yj=yj_safe+yshift*boxysize
15188           zj=zj_safe+zshift*boxzsize
15189           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15190           if(dist_temp.lt.dist_init) then
15191             dist_init=dist_temp
15192             xj_temp=xj
15193             yj_temp=yj
15194             zj_temp=zj
15195             subchap=1
15196           endif
15197        enddo
15198        enddo
15199        enddo
15200        if (subchap.eq.1) then
15201           xj=xj_temp-xi
15202           yj=yj_temp-yi
15203           zj=zj_temp-zi
15204        else
15205           xj=xj_safe-xi
15206           yj=yj_safe-yi
15207           zj=zj_safe-zi
15208        endif
15209           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15210
15211           rij=dsqrt(1.0d0/rrij)
15212             sss_ele_cut=sscale_ele(rij)
15213             sss_ele_grad=sscagrad_ele(rij)
15214 !            print *,sss_ele_cut,sss_ele_grad,&
15215 !            (rij),r_cut_ele,rlamb_ele
15216             if (sss_ele_cut.le.0.0) cycle
15217           sss=sscale((rij/rscp(itypj,iteli)))
15218           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15219           if (sss.lt.1.0d0) then
15220
15221             fac=rrij**expon2
15222             e1=fac*fac*aad(itypj,iteli)
15223             e2=fac*bad(itypj,iteli)
15224             if (iabs(j-i) .le. 2) then
15225               e1=scal14*e1
15226               e2=scal14*e2
15227               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15228             endif
15229             evdwij=e1+e2
15230             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15231             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15232                 'evdw2',i,j,sss,evdwij
15233 !
15234 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15235 !
15236             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15237             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15238             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15239             ggg(1)=xj*fac
15240             ggg(2)=yj*fac
15241             ggg(3)=zj*fac
15242 ! Uncomment following three lines for SC-p interactions
15243 !           do k=1,3
15244 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15245 !           enddo
15246 ! Uncomment following line for SC-p interactions
15247 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15248             do k=1,3
15249               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15250               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15251             enddo
15252           endif
15253         enddo
15254
15255         enddo ! iint
15256       enddo ! i
15257       do i=1,nct
15258         do j=1,3
15259           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15260           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15261           gradx_scp(j,i)=expon*gradx_scp(j,i)
15262         enddo
15263       enddo
15264 !******************************************************************************
15265 !
15266 !                              N O T E !!!
15267 !
15268 ! To save time the factor EXPON has been extracted from ALL components
15269 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15270 ! use!
15271 !
15272 !******************************************************************************
15273       return
15274       end subroutine escp_long
15275 !-----------------------------------------------------------------------------
15276       subroutine escp_short(evdw2,evdw2_14)
15277 !
15278 ! This subroutine calculates the excluded-volume interaction energy between
15279 ! peptide-group centers and side chains and its gradient in virtual-bond and
15280 ! side-chain vectors.
15281 !
15282 !      implicit real*8 (a-h,o-z)
15283 !      include 'DIMENSIONS'
15284 !      include 'COMMON.GEO'
15285 !      include 'COMMON.VAR'
15286 !      include 'COMMON.LOCAL'
15287 !      include 'COMMON.CHAIN'
15288 !      include 'COMMON.DERIV'
15289 !      include 'COMMON.INTERACT'
15290 !      include 'COMMON.FFIELD'
15291 !      include 'COMMON.IOUNITS'
15292 !      include 'COMMON.CONTROL'
15293       real(kind=8),dimension(3) :: ggg
15294 !el local variables
15295       integer :: i,iint,j,k,iteli,itypj,subchap
15296       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15297       real(kind=8) :: evdw2,evdw2_14,evdwij
15298       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15299                     dist_temp, dist_init
15300
15301       evdw2=0.0D0
15302       evdw2_14=0.0d0
15303 !d    print '(a)','Enter ESCP'
15304 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15305       do i=iatscp_s,iatscp_e
15306         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15307         iteli=itel(i)
15308         xi=0.5D0*(c(1,i)+c(1,i+1))
15309         yi=0.5D0*(c(2,i)+c(2,i+1))
15310         zi=0.5D0*(c(3,i)+c(3,i+1))
15311           xi=mod(xi,boxxsize)
15312           if (xi.lt.0) xi=xi+boxxsize
15313           yi=mod(yi,boxysize)
15314           if (yi.lt.0) yi=yi+boxysize
15315           zi=mod(zi,boxzsize)
15316           if (zi.lt.0) zi=zi+boxzsize
15317
15318         do iint=1,nscp_gr(i)
15319
15320         do j=iscpstart(i,iint),iscpend(i,iint)
15321           itypj=itype(j,1)
15322           if (itypj.eq.ntyp1) cycle
15323 ! Uncomment following three lines for SC-p interactions
15324 !         xj=c(1,nres+j)-xi
15325 !         yj=c(2,nres+j)-yi
15326 !         zj=c(3,nres+j)-zi
15327 ! Uncomment following three lines for Ca-p interactions
15328 !          xj=c(1,j)-xi
15329 !          yj=c(2,j)-yi
15330 !          zj=c(3,j)-zi
15331           xj=c(1,j)
15332           yj=c(2,j)
15333           zj=c(3,j)
15334           xj=mod(xj,boxxsize)
15335           if (xj.lt.0) xj=xj+boxxsize
15336           yj=mod(yj,boxysize)
15337           if (yj.lt.0) yj=yj+boxysize
15338           zj=mod(zj,boxzsize)
15339           if (zj.lt.0) zj=zj+boxzsize
15340       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15341       xj_safe=xj
15342       yj_safe=yj
15343       zj_safe=zj
15344       subchap=0
15345       do xshift=-1,1
15346       do yshift=-1,1
15347       do zshift=-1,1
15348           xj=xj_safe+xshift*boxxsize
15349           yj=yj_safe+yshift*boxysize
15350           zj=zj_safe+zshift*boxzsize
15351           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15352           if(dist_temp.lt.dist_init) then
15353             dist_init=dist_temp
15354             xj_temp=xj
15355             yj_temp=yj
15356             zj_temp=zj
15357             subchap=1
15358           endif
15359        enddo
15360        enddo
15361        enddo
15362        if (subchap.eq.1) then
15363           xj=xj_temp-xi
15364           yj=yj_temp-yi
15365           zj=zj_temp-zi
15366        else
15367           xj=xj_safe-xi
15368           yj=yj_safe-yi
15369           zj=zj_safe-zi
15370        endif
15371
15372           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15373           rij=dsqrt(1.0d0/rrij)
15374             sss_ele_cut=sscale_ele(rij)
15375             sss_ele_grad=sscagrad_ele(rij)
15376 !            print *,sss_ele_cut,sss_ele_grad,&
15377 !            (rij),r_cut_ele,rlamb_ele
15378             if (sss_ele_cut.le.0.0) cycle
15379           sss=sscale(rij/rscp(itypj,iteli))
15380           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15381           if (sss.gt.0.0d0) then
15382
15383             fac=rrij**expon2
15384             e1=fac*fac*aad(itypj,iteli)
15385             e2=fac*bad(itypj,iteli)
15386             if (iabs(j-i) .le. 2) then
15387               e1=scal14*e1
15388               e2=scal14*e2
15389               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15390             endif
15391             evdwij=e1+e2
15392             evdw2=evdw2+evdwij*sss*sss_ele_cut
15393             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15394                 'evdw2',i,j,sss,evdwij
15395 !
15396 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15397 !
15398             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15399             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15400             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15401
15402             ggg(1)=xj*fac
15403             ggg(2)=yj*fac
15404             ggg(3)=zj*fac
15405 ! Uncomment following three lines for SC-p interactions
15406 !           do k=1,3
15407 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15408 !           enddo
15409 ! Uncomment following line for SC-p interactions
15410 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15411             do k=1,3
15412               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15413               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15414             enddo
15415           endif
15416         enddo
15417
15418         enddo ! iint
15419       enddo ! i
15420       do i=1,nct
15421         do j=1,3
15422           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15423           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15424           gradx_scp(j,i)=expon*gradx_scp(j,i)
15425         enddo
15426       enddo
15427 !******************************************************************************
15428 !
15429 !                              N O T E !!!
15430 !
15431 ! To save time the factor EXPON has been extracted from ALL components
15432 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15433 ! use!
15434 !
15435 !******************************************************************************
15436       return
15437       end subroutine escp_short
15438 !-----------------------------------------------------------------------------
15439 ! energy_p_new-sep_barrier.F
15440 !-----------------------------------------------------------------------------
15441       subroutine sc_grad_scale(scalfac)
15442 !      implicit real*8 (a-h,o-z)
15443       use calc_data
15444 !      include 'DIMENSIONS'
15445 !      include 'COMMON.CHAIN'
15446 !      include 'COMMON.DERIV'
15447 !      include 'COMMON.CALC'
15448 !      include 'COMMON.IOUNITS'
15449       real(kind=8),dimension(3) :: dcosom1,dcosom2
15450       real(kind=8) :: scalfac
15451 !el local variables
15452 !      integer :: i,j,k,l
15453
15454       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15455       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15456       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15457            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15458 ! diagnostics only
15459 !      eom1=0.0d0
15460 !      eom2=0.0d0
15461 !      eom12=evdwij*eps1_om12
15462 ! end diagnostics
15463 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15464 !     &  " sigder",sigder
15465 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15466 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15467       do k=1,3
15468         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15469         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15470       enddo
15471       do k=1,3
15472         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15473          *sss_ele_cut
15474       enddo
15475 !      write (iout,*) "gg",(gg(k),k=1,3)
15476       do k=1,3
15477         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15478                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15479                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15480                  *sss_ele_cut
15481         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15482                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15483                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15484          *sss_ele_cut
15485 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15486 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15487 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15488 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15489       enddo
15490 !
15491 ! Calculate the components of the gradient in DC and X
15492 !
15493       do l=1,3
15494         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15495         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15496       enddo
15497       return
15498       end subroutine sc_grad_scale
15499 !-----------------------------------------------------------------------------
15500 ! energy_split-sep.F
15501 !-----------------------------------------------------------------------------
15502       subroutine etotal_long(energia)
15503 !
15504 ! Compute the long-range slow-varying contributions to the energy
15505 !
15506 !      implicit real*8 (a-h,o-z)
15507 !      include 'DIMENSIONS'
15508       use MD_data, only: totT,usampl,eq_time
15509 #ifndef ISNAN
15510       external proc_proc
15511 #ifdef WINPGI
15512 !MS$ATTRIBUTES C ::  proc_proc
15513 #endif
15514 #endif
15515 #ifdef MPI
15516       include "mpif.h"
15517       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15518 #endif
15519 !      include 'COMMON.SETUP'
15520 !      include 'COMMON.IOUNITS'
15521 !      include 'COMMON.FFIELD'
15522 !      include 'COMMON.DERIV'
15523 !      include 'COMMON.INTERACT'
15524 !      include 'COMMON.SBRIDGE'
15525 !      include 'COMMON.CHAIN'
15526 !      include 'COMMON.VAR'
15527 !      include 'COMMON.LOCAL'
15528 !      include 'COMMON.MD'
15529       real(kind=8),dimension(0:n_ene) :: energia
15530 !el local variables
15531       integer :: i,n_corr,n_corr1,ierror,ierr
15532       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15533                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15534                   ecorr,ecorr5,ecorr6,eturn6,time00
15535 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15536 !elwrite(iout,*)"in etotal long"
15537
15538       if (modecalc.eq.12.or.modecalc.eq.14) then
15539 #ifdef MPI
15540 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15541 #else
15542         call int_from_cart1(.false.)
15543 #endif
15544       endif
15545 !elwrite(iout,*)"in etotal long"
15546
15547 #ifdef MPI
15548 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15549 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15550       call flush(iout)
15551       if (nfgtasks.gt.1) then
15552         time00=MPI_Wtime()
15553 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15554         if (fg_rank.eq.0) then
15555           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15556 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15557 !          call flush(iout)
15558 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15559 ! FG slaves as WEIGHTS array.
15560           weights_(1)=wsc
15561           weights_(2)=wscp
15562           weights_(3)=welec
15563           weights_(4)=wcorr
15564           weights_(5)=wcorr5
15565           weights_(6)=wcorr6
15566           weights_(7)=wel_loc
15567           weights_(8)=wturn3
15568           weights_(9)=wturn4
15569           weights_(10)=wturn6
15570           weights_(11)=wang
15571           weights_(12)=wscloc
15572           weights_(13)=wtor
15573           weights_(14)=wtor_d
15574           weights_(15)=wstrain
15575           weights_(16)=wvdwpp
15576           weights_(17)=wbond
15577           weights_(18)=scal14
15578           weights_(21)=wsccor
15579 ! FG Master broadcasts the WEIGHTS_ array
15580           call MPI_Bcast(weights_(1),n_ene,&
15581               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15582         else
15583 ! FG slaves receive the WEIGHTS array
15584           call MPI_Bcast(weights(1),n_ene,&
15585               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15586           wsc=weights(1)
15587           wscp=weights(2)
15588           welec=weights(3)
15589           wcorr=weights(4)
15590           wcorr5=weights(5)
15591           wcorr6=weights(6)
15592           wel_loc=weights(7)
15593           wturn3=weights(8)
15594           wturn4=weights(9)
15595           wturn6=weights(10)
15596           wang=weights(11)
15597           wscloc=weights(12)
15598           wtor=weights(13)
15599           wtor_d=weights(14)
15600           wstrain=weights(15)
15601           wvdwpp=weights(16)
15602           wbond=weights(17)
15603           scal14=weights(18)
15604           wsccor=weights(21)
15605         endif
15606         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15607           king,FG_COMM,IERR)
15608          time_Bcast=time_Bcast+MPI_Wtime()-time00
15609          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15610 !        call chainbuild_cart
15611 !        call int_from_cart1(.false.)
15612       endif
15613 !      write (iout,*) 'Processor',myrank,
15614 !     &  ' calling etotal_short ipot=',ipot
15615 !      call flush(iout)
15616 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15617 #endif
15618 !d    print *,'nnt=',nnt,' nct=',nct
15619 !
15620 !elwrite(iout,*)"in etotal long"
15621 ! Compute the side-chain and electrostatic interaction energy
15622 !
15623       goto (101,102,103,104,105,106) ipot
15624 ! Lennard-Jones potential.
15625   101 call elj_long(evdw)
15626 !d    print '(a)','Exit ELJ'
15627       goto 107
15628 ! Lennard-Jones-Kihara potential (shifted).
15629   102 call eljk_long(evdw)
15630       goto 107
15631 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15632   103 call ebp_long(evdw)
15633       goto 107
15634 ! Gay-Berne potential (shifted LJ, angular dependence).
15635   104 call egb_long(evdw)
15636       goto 107
15637 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15638   105 call egbv_long(evdw)
15639       goto 107
15640 ! Soft-sphere potential
15641   106 call e_softsphere(evdw)
15642 !
15643 ! Calculate electrostatic (H-bonding) energy of the main chain.
15644 !
15645   107 continue
15646       call vec_and_deriv
15647       if (ipot.lt.6) then
15648 #ifdef SPLITELE
15649          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15650              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15651              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15652              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15653 #else
15654          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15655              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15656              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15657              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15658 #endif
15659            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15660          else
15661             ees=0
15662             evdw1=0
15663             eel_loc=0
15664             eello_turn3=0
15665             eello_turn4=0
15666          endif
15667       else
15668 !        write (iout,*) "Soft-spheer ELEC potential"
15669         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15670          eello_turn4)
15671       endif
15672 !
15673 ! Calculate excluded-volume interaction energy between peptide groups
15674 ! and side chains.
15675 !
15676       if (ipot.lt.6) then
15677        if(wscp.gt.0d0) then
15678         call escp_long(evdw2,evdw2_14)
15679        else
15680         evdw2=0
15681         evdw2_14=0
15682        endif
15683       else
15684         call escp_soft_sphere(evdw2,evdw2_14)
15685       endif
15686 !
15687 ! 12/1/95 Multi-body terms
15688 !
15689       n_corr=0
15690       n_corr1=0
15691       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15692           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15693          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15694 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15695 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15696       else
15697          ecorr=0.0d0
15698          ecorr5=0.0d0
15699          ecorr6=0.0d0
15700          eturn6=0.0d0
15701       endif
15702       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15703          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15704       endif
15705 !
15706 ! If performing constraint dynamics, call the constraint energy
15707 !  after the equilibration time
15708       if(usampl.and.totT.gt.eq_time) then
15709          call EconstrQ
15710          call Econstr_back
15711       else
15712          Uconst=0.0d0
15713          Uconst_back=0.0d0
15714       endif
15715 !
15716 ! Sum the energies
15717 !
15718       do i=1,n_ene
15719         energia(i)=0.0d0
15720       enddo
15721       energia(1)=evdw
15722 #ifdef SCP14
15723       energia(2)=evdw2-evdw2_14
15724       energia(18)=evdw2_14
15725 #else
15726       energia(2)=evdw2
15727       energia(18)=0.0d0
15728 #endif
15729 #ifdef SPLITELE
15730       energia(3)=ees
15731       energia(16)=evdw1
15732 #else
15733       energia(3)=ees+evdw1
15734       energia(16)=0.0d0
15735 #endif
15736       energia(4)=ecorr
15737       energia(5)=ecorr5
15738       energia(6)=ecorr6
15739       energia(7)=eel_loc
15740       energia(8)=eello_turn3
15741       energia(9)=eello_turn4
15742       energia(10)=eturn6
15743       energia(20)=Uconst+Uconst_back
15744       call sum_energy(energia,.true.)
15745 !      write (iout,*) "Exit ETOTAL_LONG"
15746       call flush(iout)
15747       return
15748       end subroutine etotal_long
15749 !-----------------------------------------------------------------------------
15750       subroutine etotal_short(energia)
15751 !
15752 ! Compute the short-range fast-varying contributions to the energy
15753 !
15754 !      implicit real*8 (a-h,o-z)
15755 !      include 'DIMENSIONS'
15756 #ifndef ISNAN
15757       external proc_proc
15758 #ifdef WINPGI
15759 !MS$ATTRIBUTES C ::  proc_proc
15760 #endif
15761 #endif
15762 #ifdef MPI
15763       include "mpif.h"
15764       integer :: ierror,ierr
15765       real(kind=8),dimension(n_ene) :: weights_
15766       real(kind=8) :: time00
15767 #endif
15768 !      include 'COMMON.SETUP'
15769 !      include 'COMMON.IOUNITS'
15770 !      include 'COMMON.FFIELD'
15771 !      include 'COMMON.DERIV'
15772 !      include 'COMMON.INTERACT'
15773 !      include 'COMMON.SBRIDGE'
15774 !      include 'COMMON.CHAIN'
15775 !      include 'COMMON.VAR'
15776 !      include 'COMMON.LOCAL'
15777       real(kind=8),dimension(0:n_ene) :: energia
15778 !el local variables
15779       integer :: i,nres6
15780       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15781       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15782       nres6=6*nres
15783
15784 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15785 !      call flush(iout)
15786       if (modecalc.eq.12.or.modecalc.eq.14) then
15787 #ifdef MPI
15788         if (fg_rank.eq.0) call int_from_cart1(.false.)
15789 #else
15790         call int_from_cart1(.false.)
15791 #endif
15792       endif
15793 #ifdef MPI
15794 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15795 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15796 !      call flush(iout)
15797       if (nfgtasks.gt.1) then
15798         time00=MPI_Wtime()
15799 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15800         if (fg_rank.eq.0) then
15801           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15802 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15803 !          call flush(iout)
15804 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15805 ! FG slaves as WEIGHTS array.
15806           weights_(1)=wsc
15807           weights_(2)=wscp
15808           weights_(3)=welec
15809           weights_(4)=wcorr
15810           weights_(5)=wcorr5
15811           weights_(6)=wcorr6
15812           weights_(7)=wel_loc
15813           weights_(8)=wturn3
15814           weights_(9)=wturn4
15815           weights_(10)=wturn6
15816           weights_(11)=wang
15817           weights_(12)=wscloc
15818           weights_(13)=wtor
15819           weights_(14)=wtor_d
15820           weights_(15)=wstrain
15821           weights_(16)=wvdwpp
15822           weights_(17)=wbond
15823           weights_(18)=scal14
15824           weights_(21)=wsccor
15825 ! FG Master broadcasts the WEIGHTS_ array
15826           call MPI_Bcast(weights_(1),n_ene,&
15827               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15828         else
15829 ! FG slaves receive the WEIGHTS array
15830           call MPI_Bcast(weights(1),n_ene,&
15831               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15832           wsc=weights(1)
15833           wscp=weights(2)
15834           welec=weights(3)
15835           wcorr=weights(4)
15836           wcorr5=weights(5)
15837           wcorr6=weights(6)
15838           wel_loc=weights(7)
15839           wturn3=weights(8)
15840           wturn4=weights(9)
15841           wturn6=weights(10)
15842           wang=weights(11)
15843           wscloc=weights(12)
15844           wtor=weights(13)
15845           wtor_d=weights(14)
15846           wstrain=weights(15)
15847           wvdwpp=weights(16)
15848           wbond=weights(17)
15849           scal14=weights(18)
15850           wsccor=weights(21)
15851         endif
15852 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15853         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15854           king,FG_COMM,IERR)
15855 !        write (iout,*) "Processor",myrank," BROADCAST c"
15856         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15857           king,FG_COMM,IERR)
15858 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15859         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15860           king,FG_COMM,IERR)
15861 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15862         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15863           king,FG_COMM,IERR)
15864 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15865         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15866           king,FG_COMM,IERR)
15867 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15868         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15869           king,FG_COMM,IERR)
15870 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15871         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15872           king,FG_COMM,IERR)
15873 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15874         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15875           king,FG_COMM,IERR)
15876 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15877         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15878           king,FG_COMM,IERR)
15879          time_Bcast=time_Bcast+MPI_Wtime()-time00
15880 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15881       endif
15882 !      write (iout,*) 'Processor',myrank,
15883 !     &  ' calling etotal_short ipot=',ipot
15884 !      call flush(iout)
15885 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15886 #endif
15887 !      call int_from_cart1(.false.)
15888 !
15889 ! Compute the side-chain and electrostatic interaction energy
15890 !
15891       goto (101,102,103,104,105,106) ipot
15892 ! Lennard-Jones potential.
15893   101 call elj_short(evdw)
15894 !d    print '(a)','Exit ELJ'
15895       goto 107
15896 ! Lennard-Jones-Kihara potential (shifted).
15897   102 call eljk_short(evdw)
15898       goto 107
15899 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15900   103 call ebp_short(evdw)
15901       goto 107
15902 ! Gay-Berne potential (shifted LJ, angular dependence).
15903   104 call egb_short(evdw)
15904       goto 107
15905 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15906   105 call egbv_short(evdw)
15907       goto 107
15908 ! Soft-sphere potential - already dealt with in the long-range part
15909   106 evdw=0.0d0
15910 !  106 call e_softsphere_short(evdw)
15911 !
15912 ! Calculate electrostatic (H-bonding) energy of the main chain.
15913 !
15914   107 continue
15915 !
15916 ! Calculate the short-range part of Evdwpp
15917 !
15918       call evdwpp_short(evdw1)
15919 !
15920 ! Calculate the short-range part of ESCp
15921 !
15922       if (ipot.lt.6) then
15923         call escp_short(evdw2,evdw2_14)
15924       endif
15925 !
15926 ! Calculate the bond-stretching energy
15927 !
15928       call ebond(estr)
15929 !
15930 ! Calculate the disulfide-bridge and other energy and the contributions
15931 ! from other distance constraints.
15932       call edis(ehpb)
15933 !
15934 ! Calculate the virtual-bond-angle energy.
15935 !
15936       call ebend(ebe,ethetacnstr)
15937 !
15938 ! Calculate the SC local energy.
15939 !
15940       call vec_and_deriv
15941       call esc(escloc)
15942 !
15943 ! Calculate the virtual-bond torsional energy.
15944 !
15945       call etor(etors,edihcnstr)
15946 !
15947 ! 6/23/01 Calculate double-torsional energy
15948 !
15949       call etor_d(etors_d)
15950 !
15951 ! 21/5/07 Calculate local sicdechain correlation energy
15952 !
15953       if (wsccor.gt.0.0d0) then
15954         call eback_sc_corr(esccor)
15955       else
15956         esccor=0.0d0
15957       endif
15958 !
15959 ! Put energy components into an array
15960 !
15961       do i=1,n_ene
15962         energia(i)=0.0d0
15963       enddo
15964       energia(1)=evdw
15965 #ifdef SCP14
15966       energia(2)=evdw2-evdw2_14
15967       energia(18)=evdw2_14
15968 #else
15969       energia(2)=evdw2
15970       energia(18)=0.0d0
15971 #endif
15972 #ifdef SPLITELE
15973       energia(16)=evdw1
15974 #else
15975       energia(3)=evdw1
15976 #endif
15977       energia(11)=ebe
15978       energia(12)=escloc
15979       energia(13)=etors
15980       energia(14)=etors_d
15981       energia(15)=ehpb
15982       energia(17)=estr
15983       energia(19)=edihcnstr
15984       energia(21)=esccor
15985 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15986       call flush(iout)
15987       call sum_energy(energia,.true.)
15988 !      write (iout,*) "Exit ETOTAL_SHORT"
15989       call flush(iout)
15990       return
15991       end subroutine etotal_short
15992 !-----------------------------------------------------------------------------
15993 ! gnmr1.f
15994 !-----------------------------------------------------------------------------
15995       real(kind=8) function gnmr1(y,ymin,ymax)
15996 !      implicit none
15997       real(kind=8) :: y,ymin,ymax
15998       real(kind=8) :: wykl=4.0d0
15999       if (y.lt.ymin) then
16000         gnmr1=(ymin-y)**wykl/wykl
16001       else if (y.gt.ymax) then
16002         gnmr1=(y-ymax)**wykl/wykl
16003       else
16004         gnmr1=0.0d0
16005       endif
16006       return
16007       end function gnmr1
16008 !-----------------------------------------------------------------------------
16009       real(kind=8) function gnmr1prim(y,ymin,ymax)
16010 !      implicit none
16011       real(kind=8) :: y,ymin,ymax
16012       real(kind=8) :: wykl=4.0d0
16013       if (y.lt.ymin) then
16014         gnmr1prim=-(ymin-y)**(wykl-1)
16015       else if (y.gt.ymax) then
16016         gnmr1prim=(y-ymax)**(wykl-1)
16017       else
16018         gnmr1prim=0.0d0
16019       endif
16020       return
16021       end function gnmr1prim
16022 !----------------------------------------------------------------------------
16023       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16024       real(kind=8) y,ymin,ymax,sigma
16025       real(kind=8) wykl /4.0d0/
16026       if (y.lt.ymin) then
16027         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16028       else if (y.gt.ymax) then
16029         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16030       else
16031         rlornmr1=0.0d0
16032       endif
16033       return
16034       end function rlornmr1
16035 !------------------------------------------------------------------------------
16036       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16037       real(kind=8) y,ymin,ymax,sigma
16038       real(kind=8) wykl /4.0d0/
16039       if (y.lt.ymin) then
16040         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16041         ((ymin-y)**wykl+sigma**wykl)**2
16042       else if (y.gt.ymax) then
16043         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16044         ((y-ymax)**wykl+sigma**wykl)**2
16045       else
16046         rlornmr1prim=0.0d0
16047       endif
16048       return
16049       end function rlornmr1prim
16050
16051       real(kind=8) function harmonic(y,ymax)
16052 !      implicit none
16053       real(kind=8) :: y,ymax
16054       real(kind=8) :: wykl=2.0d0
16055       harmonic=(y-ymax)**wykl
16056       return
16057       end function harmonic
16058 !-----------------------------------------------------------------------------
16059       real(kind=8) function harmonicprim(y,ymax)
16060       real(kind=8) :: y,ymin,ymax
16061       real(kind=8) :: wykl=2.0d0
16062       harmonicprim=(y-ymax)*wykl
16063       return
16064       end function harmonicprim
16065 !-----------------------------------------------------------------------------
16066 ! gradient_p.F
16067 !-----------------------------------------------------------------------------
16068       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16069
16070       use io_base, only:intout,briefout
16071 !      implicit real*8 (a-h,o-z)
16072 !      include 'DIMENSIONS'
16073 !      include 'COMMON.CHAIN'
16074 !      include 'COMMON.DERIV'
16075 !      include 'COMMON.VAR'
16076 !      include 'COMMON.INTERACT'
16077 !      include 'COMMON.FFIELD'
16078 !      include 'COMMON.MD'
16079 !      include 'COMMON.IOUNITS'
16080       real(kind=8),external :: ufparm
16081       integer :: uiparm(1)
16082       real(kind=8) :: urparm(1)
16083       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16084       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16085       integer :: n,nf,ind,ind1,i,k,j
16086 !
16087 ! This subroutine calculates total internal coordinate gradient.
16088 ! Depending on the number of function evaluations, either whole energy
16089 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16090 ! internal coordinates are reevaluated or only the cartesian-in-internal
16091 ! coordinate derivatives are evaluated. The subroutine was designed to work
16092 ! with SUMSL.
16093 !
16094 !
16095       icg=mod(nf,2)+1
16096
16097 !d      print *,'grad',nf,icg
16098       if (nf-nfl+1) 20,30,40
16099    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16100 !    write (iout,*) 'grad 20'
16101       if (nf.eq.0) return
16102       goto 40
16103    30 call var_to_geom(n,x)
16104       call chainbuild
16105 !    write (iout,*) 'grad 30'
16106 !
16107 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16108 !
16109    40 call cartder
16110 !     write (iout,*) 'grad 40'
16111 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16112 !
16113 ! Convert the Cartesian gradient into internal-coordinate gradient.
16114 !
16115       ind=0
16116       ind1=0
16117       do i=1,nres-2
16118       gthetai=0.0D0
16119       gphii=0.0D0
16120       do j=i+1,nres-1
16121           ind=ind+1
16122 !         ind=indmat(i,j)
16123 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16124         do k=1,3
16125             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16126           enddo
16127         do k=1,3
16128           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16129           enddo
16130         enddo
16131       do j=i+1,nres-1
16132           ind1=ind1+1
16133 !         ind1=indmat(i,j)
16134 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16135         do k=1,3
16136           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16137           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16138           enddo
16139         enddo
16140       if (i.gt.1) g(i-1)=gphii
16141       if (n.gt.nphi) g(nphi+i)=gthetai
16142       enddo
16143       if (n.le.nphi+ntheta) goto 10
16144       do i=2,nres-1
16145       if (itype(i,1).ne.10) then
16146           galphai=0.0D0
16147         gomegai=0.0D0
16148         do k=1,3
16149           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16150           enddo
16151         do k=1,3
16152           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16153           enddo
16154           g(ialph(i,1))=galphai
16155         g(ialph(i,1)+nside)=gomegai
16156         endif
16157       enddo
16158 !
16159 ! Add the components corresponding to local energy terms.
16160 !
16161    10 continue
16162       do i=1,nvar
16163 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16164         g(i)=g(i)+gloc(i,icg)
16165       enddo
16166 ! Uncomment following three lines for diagnostics.
16167 !d    call intout
16168 !elwrite(iout,*) "in gradient after calling intout"
16169 !d    call briefout(0,0.0d0)
16170 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16171       return
16172       end subroutine gradient
16173 !-----------------------------------------------------------------------------
16174       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16175
16176       use comm_chu
16177 !      implicit real*8 (a-h,o-z)
16178 !      include 'DIMENSIONS'
16179 !      include 'COMMON.DERIV'
16180 !      include 'COMMON.IOUNITS'
16181 !      include 'COMMON.GEO'
16182       integer :: n,nf
16183 !el      integer :: jjj
16184 !el      common /chuju/ jjj
16185       real(kind=8) :: energia(0:n_ene)
16186       integer :: uiparm(1)
16187       real(kind=8) :: urparm(1)
16188       real(kind=8) :: f
16189       real(kind=8),external :: ufparm
16190       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16191 !     if (jjj.gt.0) then
16192 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16193 !     endif
16194       nfl=nf
16195       icg=mod(nf,2)+1
16196 !d      print *,'func',nf,nfl,icg
16197       call var_to_geom(n,x)
16198       call zerograd
16199       call chainbuild
16200 !d    write (iout,*) 'ETOTAL called from FUNC'
16201       call etotal(energia)
16202       call sum_gradient
16203       f=energia(0)
16204 !     if (jjj.gt.0) then
16205 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16206 !       write (iout,*) 'f=',etot
16207 !       jjj=0
16208 !     endif
16209       return
16210       end subroutine func
16211 !-----------------------------------------------------------------------------
16212       subroutine cartgrad
16213 !      implicit real*8 (a-h,o-z)
16214 !      include 'DIMENSIONS'
16215       use energy_data
16216       use MD_data, only: totT,usampl,eq_time
16217 #ifdef MPI
16218       include 'mpif.h'
16219 #endif
16220 !      include 'COMMON.CHAIN'
16221 !      include 'COMMON.DERIV'
16222 !      include 'COMMON.VAR'
16223 !      include 'COMMON.INTERACT'
16224 !      include 'COMMON.FFIELD'
16225 !      include 'COMMON.MD'
16226 !      include 'COMMON.IOUNITS'
16227 !      include 'COMMON.TIME1'
16228 !
16229       integer :: i,j
16230
16231 ! This subrouting calculates total Cartesian coordinate gradient.
16232 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16233 !
16234 !el#define DEBUG
16235 #ifdef TIMING
16236       time00=MPI_Wtime()
16237 #endif
16238       icg=1
16239       call sum_gradient
16240 #ifdef TIMING
16241 #endif
16242 !el      write (iout,*) "After sum_gradient"
16243 #ifdef DEBUG
16244 !el      write (iout,*) "After sum_gradient"
16245       do i=1,nres-1
16246         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16247         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16248       enddo
16249 #endif
16250 ! If performing constraint dynamics, add the gradients of the constraint energy
16251       if(usampl.and.totT.gt.eq_time) then
16252          do i=1,nct
16253            do j=1,3
16254              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16255              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16256            enddo
16257          enddo
16258          do i=1,nres-3
16259            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16260          enddo
16261          do i=1,nres-2
16262            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16263          enddo
16264       endif
16265 !elwrite (iout,*) "After sum_gradient"
16266 #ifdef TIMING
16267       time01=MPI_Wtime()
16268 #endif
16269       call intcartderiv
16270 !elwrite (iout,*) "After sum_gradient"
16271 #ifdef TIMING
16272       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16273 #endif
16274 !     call checkintcartgrad
16275 !     write(iout,*) 'calling int_to_cart'
16276 #ifdef DEBUG
16277       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16278 #endif
16279       do i=0,nct
16280         do j=1,3
16281           gcart(j,i)=gradc(j,i,icg)
16282           gxcart(j,i)=gradx(j,i,icg)
16283 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16284         enddo
16285 #ifdef DEBUG
16286         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16287           (gxcart(j,i),j=1,3),gloc(i,icg)
16288 #endif
16289       enddo
16290 #ifdef TIMING
16291       time01=MPI_Wtime()
16292 #endif
16293 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16294       call int_to_cart
16295 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16296
16297 #ifdef TIMING
16298             time_inttocart=time_inttocart+MPI_Wtime()-time01
16299 #endif
16300 #ifdef DEBUG
16301             write (iout,*) "gcart and gxcart after int_to_cart"
16302             do i=0,nres-1
16303             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16304                 (gxcart(j,i),j=1,3)
16305             enddo
16306 #endif
16307 #ifdef CARGRAD
16308 #ifdef DEBUG
16309             write (iout,*) "CARGRAD"
16310 #endif
16311             do i=nres,0,-1
16312             do j=1,3
16313               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16314       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16315             enddo
16316       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16317       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16318             enddo
16319       ! Correction: dummy residues
16320             if (nnt.gt.1) then
16321               do j=1,3
16322       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16323                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16324               enddo
16325             endif
16326             if (nct.lt.nres) then
16327               do j=1,3
16328       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16329                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16330               enddo
16331             endif
16332 #endif
16333 #ifdef TIMING
16334             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16335 #endif
16336       !el#undef DEBUG
16337             return
16338             end subroutine cartgrad
16339       !-----------------------------------------------------------------------------
16340             subroutine zerograd
16341       !      implicit real*8 (a-h,o-z)
16342       !      include 'DIMENSIONS'
16343       !      include 'COMMON.DERIV'
16344       !      include 'COMMON.CHAIN'
16345       !      include 'COMMON.VAR'
16346       !      include 'COMMON.MD'
16347       !      include 'COMMON.SCCOR'
16348       !
16349       !el local variables
16350             integer :: i,j,intertyp,k
16351       ! Initialize Cartesian-coordinate gradient
16352       !
16353       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16354       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16355
16356       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16357       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16358       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16359       !      allocate(gradcorr_long(3,nres))
16360       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16361       !      allocate(gcorr6_turn_long(3,nres))
16362       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16363
16364       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16365
16366       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16367       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16368
16369       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16370       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16371
16372       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16373       !      allocate(gscloc(3,nres)) !(3,maxres)
16374       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16375
16376
16377
16378       !      common /deriv_scloc/
16379       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16380       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16381       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16382       !      common /mpgrad/
16383       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16384
16385
16386
16387       !          gradc(j,i,icg)=0.0d0
16388       !          gradx(j,i,icg)=0.0d0
16389
16390       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16391       !elwrite(iout,*) "icg",icg
16392             do i=-1,nres
16393             do j=1,3
16394               gvdwx(j,i)=0.0D0
16395               gradx_scp(j,i)=0.0D0
16396               gvdwc(j,i)=0.0D0
16397               gvdwc_scp(j,i)=0.0D0
16398               gvdwc_scpp(j,i)=0.0d0
16399               gelc(j,i)=0.0D0
16400               gelc_long(j,i)=0.0D0
16401               gradb(j,i)=0.0d0
16402               gradbx(j,i)=0.0d0
16403               gvdwpp(j,i)=0.0d0
16404               gel_loc(j,i)=0.0d0
16405               gel_loc_long(j,i)=0.0d0
16406               ghpbc(j,i)=0.0D0
16407               ghpbx(j,i)=0.0D0
16408               gcorr3_turn(j,i)=0.0d0
16409               gcorr4_turn(j,i)=0.0d0
16410               gradcorr(j,i)=0.0d0
16411               gradcorr_long(j,i)=0.0d0
16412               gradcorr5_long(j,i)=0.0d0
16413               gradcorr6_long(j,i)=0.0d0
16414               gcorr6_turn_long(j,i)=0.0d0
16415               gradcorr5(j,i)=0.0d0
16416               gradcorr6(j,i)=0.0d0
16417               gcorr6_turn(j,i)=0.0d0
16418               gsccorc(j,i)=0.0d0
16419               gsccorx(j,i)=0.0d0
16420               gradc(j,i,icg)=0.0d0
16421               gradx(j,i,icg)=0.0d0
16422               gscloc(j,i)=0.0d0
16423               gsclocx(j,i)=0.0d0
16424               gliptran(j,i)=0.0d0
16425               gliptranx(j,i)=0.0d0
16426               gliptranc(j,i)=0.0d0
16427               gshieldx(j,i)=0.0d0
16428               gshieldc(j,i)=0.0d0
16429               gshieldc_loc(j,i)=0.0d0
16430               gshieldx_ec(j,i)=0.0d0
16431               gshieldc_ec(j,i)=0.0d0
16432               gshieldc_loc_ec(j,i)=0.0d0
16433               gshieldx_t3(j,i)=0.0d0
16434               gshieldc_t3(j,i)=0.0d0
16435               gshieldc_loc_t3(j,i)=0.0d0
16436               gshieldx_t4(j,i)=0.0d0
16437               gshieldc_t4(j,i)=0.0d0
16438               gshieldc_loc_t4(j,i)=0.0d0
16439               gshieldx_ll(j,i)=0.0d0
16440               gshieldc_ll(j,i)=0.0d0
16441               gshieldc_loc_ll(j,i)=0.0d0
16442               gg_tube(j,i)=0.0d0
16443               gg_tube_sc(j,i)=0.0d0
16444               gradafm(j,i)=0.0d0
16445               gradb_nucl(j,i)=0.0d0
16446               gradbx_nucl(j,i)=0.0d0
16447               gvdwpp_nucl(j,i)=0.0d0
16448               gvdwpp(j,i)=0.0d0
16449               gelpp(j,i)=0.0d0
16450               gvdwpsb(j,i)=0.0d0
16451               gvdwpsb1(j,i)=0.0d0
16452               gvdwsbc(j,i)=0.0d0
16453               gvdwsbx(j,i)=0.0d0
16454               gelsbc(j,i)=0.0d0
16455               gradcorr_nucl(j,i)=0.0d0
16456               gradcorr3_nucl(j,i)=0.0d0
16457               gradxorr_nucl(j,i)=0.0d0
16458               gradxorr3_nucl(j,i)=0.0d0
16459               gelsbx(j,i)=0.0d0
16460               gsbloc(j,i)=0.0d0
16461               gsblocx(j,i)=0.0d0
16462               gradpepcat(j,i)=0.0d0
16463               gradpepcatx(j,i)=0.0d0
16464               gradcatcat(j,i)=0.0d0
16465               gvdwx_scbase(j,i)=0.0d0
16466               gvdwc_scbase(j,i)=0.0d0
16467               gvdwx_pepbase(j,i)=0.0d0
16468               gvdwc_pepbase(j,i)=0.0d0
16469               gvdwx_scpho(j,i)=0.0d0
16470               gvdwc_scpho(j,i)=0.0d0
16471               gvdwc_peppho(j,i)=0.0d0
16472             enddo
16473              enddo
16474             do i=0,nres
16475             do j=1,3
16476               do intertyp=1,3
16477                gloc_sc(intertyp,i,icg)=0.0d0
16478               enddo
16479             enddo
16480             enddo
16481             do i=1,nres
16482              do j=1,maxcontsshi
16483              shield_list(j,i)=0
16484             do k=1,3
16485       !C           print *,i,j,k
16486                grad_shield_side(k,j,i)=0.0d0
16487                grad_shield_loc(k,j,i)=0.0d0
16488              enddo
16489              enddo
16490              ishield_list(i)=0
16491             enddo
16492
16493       !
16494       ! Initialize the gradient of local energy terms.
16495       !
16496       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16497       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16498       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16499       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16500       !      allocate(gel_loc_turn3(nres))
16501       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16502       !      allocate(gsccor_loc(nres))      !(maxres)
16503
16504             do i=1,4*nres
16505             gloc(i,icg)=0.0D0
16506             enddo
16507             do i=1,nres
16508             gel_loc_loc(i)=0.0d0
16509             gcorr_loc(i)=0.0d0
16510             g_corr5_loc(i)=0.0d0
16511             g_corr6_loc(i)=0.0d0
16512             gel_loc_turn3(i)=0.0d0
16513             gel_loc_turn4(i)=0.0d0
16514             gel_loc_turn6(i)=0.0d0
16515             gsccor_loc(i)=0.0d0
16516             enddo
16517       ! initialize gcart and gxcart
16518       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16519             do i=0,nres
16520             do j=1,3
16521               gcart(j,i)=0.0d0
16522               gxcart(j,i)=0.0d0
16523             enddo
16524             enddo
16525             return
16526             end subroutine zerograd
16527       !-----------------------------------------------------------------------------
16528             real(kind=8) function fdum()
16529             fdum=0.0D0
16530             return
16531             end function fdum
16532       !-----------------------------------------------------------------------------
16533       ! intcartderiv.F
16534       !-----------------------------------------------------------------------------
16535             subroutine intcartderiv
16536       !      implicit real*8 (a-h,o-z)
16537       !      include 'DIMENSIONS'
16538 #ifdef MPI
16539             include 'mpif.h'
16540 #endif
16541       !      include 'COMMON.SETUP'
16542       !      include 'COMMON.CHAIN'
16543       !      include 'COMMON.VAR'
16544       !      include 'COMMON.GEO'
16545       !      include 'COMMON.INTERACT'
16546       !      include 'COMMON.DERIV'
16547       !      include 'COMMON.IOUNITS'
16548       !      include 'COMMON.LOCAL'
16549       !      include 'COMMON.SCCOR'
16550             real(kind=8) :: pi4,pi34
16551             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16552             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16553                       dcosomega,dsinomega !(3,3,maxres)
16554             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16555
16556             integer :: i,j,k
16557             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16558                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16559                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16560                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16561             integer :: nres2
16562             nres2=2*nres
16563
16564       !el from module energy-------------
16565       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16566       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16567       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16568
16569       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16570       !el      allocate(dsintau(3,3,3,0:nres2))
16571       !el      allocate(dtauangle(3,3,3,0:nres2))
16572       !el      allocate(domicron(3,2,2,0:nres2))
16573       !el      allocate(dcosomicron(3,2,2,0:nres2))
16574
16575
16576
16577 #if defined(MPI) && defined(PARINTDER)
16578             if (nfgtasks.gt.1 .and. me.eq.king) &
16579             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16580 #endif
16581             pi4 = 0.5d0*pipol
16582             pi34 = 3*pi4
16583
16584       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16585       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16586
16587       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16588             do i=1,nres
16589             do j=1,3
16590               dtheta(j,1,i)=0.0d0
16591               dtheta(j,2,i)=0.0d0
16592               dphi(j,1,i)=0.0d0
16593               dphi(j,2,i)=0.0d0
16594               dphi(j,3,i)=0.0d0
16595             enddo
16596             enddo
16597       ! Derivatives of theta's
16598 #if defined(MPI) && defined(PARINTDER)
16599       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16600             do i=max0(ithet_start-1,3),ithet_end
16601 #else
16602             do i=3,nres
16603 #endif
16604             cost=dcos(theta(i))
16605             sint=sqrt(1-cost*cost)
16606             do j=1,3
16607               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16608               vbld(i-1)
16609               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16610               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16611               vbld(i)
16612               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16613             enddo
16614             enddo
16615 #if defined(MPI) && defined(PARINTDER)
16616       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16617             do i=max0(ithet_start-1,3),ithet_end
16618 #else
16619             do i=3,nres
16620 #endif
16621             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16622             cost1=dcos(omicron(1,i))
16623             sint1=sqrt(1-cost1*cost1)
16624             cost2=dcos(omicron(2,i))
16625             sint2=sqrt(1-cost2*cost2)
16626              do j=1,3
16627       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16628               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16629               cost1*dc_norm(j,i-2))/ &
16630               vbld(i-1)
16631               domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16632               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16633               +cost1*(dc_norm(j,i-1+nres)))/ &
16634               vbld(i-1+nres)
16635               domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16636       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16637       !C Looks messy but better than if in loop
16638               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16639               +cost2*dc_norm(j,i-1))/ &
16640               vbld(i)
16641               domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16642               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16643                +cost2*(-dc_norm(j,i-1+nres)))/ &
16644               vbld(i-1+nres)
16645       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16646               domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16647             enddo
16648              endif
16649             enddo
16650       !elwrite(iout,*) "after vbld write"
16651       ! Derivatives of phi:
16652       ! If phi is 0 or 180 degrees, then the formulas
16653       ! have to be derived by power series expansion of the
16654       ! conventional formulas around 0 and 180.
16655 #ifdef PARINTDER
16656             do i=iphi1_start,iphi1_end
16657 #else
16658             do i=4,nres
16659 #endif
16660       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16661       ! the conventional case
16662             sint=dsin(theta(i))
16663             sint1=dsin(theta(i-1))
16664             sing=dsin(phi(i))
16665             cost=dcos(theta(i))
16666             cost1=dcos(theta(i-1))
16667             cosg=dcos(phi(i))
16668             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16669             fac0=1.0d0/(sint1*sint)
16670             fac1=cost*fac0
16671             fac2=cost1*fac0
16672             fac3=cosg*cost1/(sint1*sint1)
16673             fac4=cosg*cost/(sint*sint)
16674       !    Obtaining the gamma derivatives from sine derivative
16675              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16676                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16677                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16678              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16679              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16680              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16681              do j=1,3
16682                 ctgt=cost/sint
16683                 ctgt1=cost1/sint1
16684                 cosg_inv=1.0d0/cosg
16685                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16686                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16687                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16688                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16689                 dsinphi(j,2,i)= &
16690                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16691                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16692                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16693                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16694                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16695       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16696                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16697                 endif
16698       ! Bug fixed 3/24/05 (AL)
16699              enddo
16700       !   Obtaining the gamma derivatives from cosine derivative
16701             else
16702                do j=1,3
16703                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16704                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16705                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16706                dc_norm(j,i-3))/vbld(i-2)
16707                dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16708                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16709                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16710                dcostheta(j,1,i)
16711                dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16712                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16713                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16714                dc_norm(j,i-1))/vbld(i)
16715                dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16716                endif
16717              enddo
16718             endif
16719             enddo
16720       !alculate derivative of Tauangle
16721 #ifdef PARINTDER
16722             do i=itau_start,itau_end
16723 #else
16724             do i=3,nres
16725       !elwrite(iout,*) " vecpr",i,nres
16726 #endif
16727              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16728       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16729       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16730       !c dtauangle(j,intertyp,dervityp,residue number)
16731       !c INTERTYP=1 SC...Ca...Ca..Ca
16732       ! the conventional case
16733             sint=dsin(theta(i))
16734             sint1=dsin(omicron(2,i-1))
16735             sing=dsin(tauangle(1,i))
16736             cost=dcos(theta(i))
16737             cost1=dcos(omicron(2,i-1))
16738             cosg=dcos(tauangle(1,i))
16739       !elwrite(iout,*) " vecpr5",i,nres
16740             do j=1,3
16741       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16742       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16743             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16744       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16745             enddo
16746             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16747             fac0=1.0d0/(sint1*sint)
16748             fac1=cost*fac0
16749             fac2=cost1*fac0
16750             fac3=cosg*cost1/(sint1*sint1)
16751             fac4=cosg*cost/(sint*sint)
16752       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16753       !    Obtaining the gamma derivatives from sine derivative
16754              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16755                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16756                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16757              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16758              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16759              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16760             do j=1,3
16761                 ctgt=cost/sint
16762                 ctgt1=cost1/sint1
16763                 cosg_inv=1.0d0/cosg
16764                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16765              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16766              *vbld_inv(i-2+nres)
16767                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16768                 dsintau(j,1,2,i)= &
16769                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16770                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16771       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16772                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16773       ! Bug fixed 3/24/05 (AL)
16774                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16775                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16776       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16777                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16778              enddo
16779       !   Obtaining the gamma derivatives from cosine derivative
16780             else
16781                do j=1,3
16782                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16783                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16784                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16785                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16786                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16787                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16788                dcostheta(j,1,i)
16789                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16790                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16791                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16792                dc_norm(j,i-1))/vbld(i)
16793                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16794       !         write (iout,*) "else",i
16795              enddo
16796             endif
16797       !        do k=1,3
16798       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16799       !        enddo
16800             enddo
16801       !C Second case Ca...Ca...Ca...SC
16802 #ifdef PARINTDER
16803             do i=itau_start,itau_end
16804 #else
16805             do i=4,nres
16806 #endif
16807              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16808               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16809       ! the conventional case
16810             sint=dsin(omicron(1,i))
16811             sint1=dsin(theta(i-1))
16812             sing=dsin(tauangle(2,i))
16813             cost=dcos(omicron(1,i))
16814             cost1=dcos(theta(i-1))
16815             cosg=dcos(tauangle(2,i))
16816       !        do j=1,3
16817       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16818       !        enddo
16819             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16820             fac0=1.0d0/(sint1*sint)
16821             fac1=cost*fac0
16822             fac2=cost1*fac0
16823             fac3=cosg*cost1/(sint1*sint1)
16824             fac4=cosg*cost/(sint*sint)
16825       !    Obtaining the gamma derivatives from sine derivative
16826              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16827                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16828                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16829              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16830              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16831              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16832             do j=1,3
16833                 ctgt=cost/sint
16834                 ctgt1=cost1/sint1
16835                 cosg_inv=1.0d0/cosg
16836                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16837                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16838       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16839       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16840                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16841                 dsintau(j,2,2,i)= &
16842                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16843                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16844       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16845       !     & sing*ctgt*domicron(j,1,2,i),
16846       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16847                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16848       ! Bug fixed 3/24/05 (AL)
16849                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16850                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16851       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16852                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16853              enddo
16854       !   Obtaining the gamma derivatives from cosine derivative
16855             else
16856                do j=1,3
16857                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16858                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16859                dc_norm(j,i-3))/vbld(i-2)
16860                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16861                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16862                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16863                dcosomicron(j,1,1,i)
16864                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16865                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16866                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16867                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16868                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16869       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16870              enddo
16871             endif
16872             enddo
16873
16874       !CC third case SC...Ca...Ca...SC
16875 #ifdef PARINTDER
16876
16877             do i=itau_start,itau_end
16878 #else
16879             do i=3,nres
16880 #endif
16881       ! the conventional case
16882             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16883             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16884             sint=dsin(omicron(1,i))
16885             sint1=dsin(omicron(2,i-1))
16886             sing=dsin(tauangle(3,i))
16887             cost=dcos(omicron(1,i))
16888             cost1=dcos(omicron(2,i-1))
16889             cosg=dcos(tauangle(3,i))
16890             do j=1,3
16891             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16892       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16893             enddo
16894             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16895             fac0=1.0d0/(sint1*sint)
16896             fac1=cost*fac0
16897             fac2=cost1*fac0
16898             fac3=cosg*cost1/(sint1*sint1)
16899             fac4=cosg*cost/(sint*sint)
16900       !    Obtaining the gamma derivatives from sine derivative
16901              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16902                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16903                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16904              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16905              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16906              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16907             do j=1,3
16908                 ctgt=cost/sint
16909                 ctgt1=cost1/sint1
16910                 cosg_inv=1.0d0/cosg
16911                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16912                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16913                   *vbld_inv(i-2+nres)
16914                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16915                 dsintau(j,3,2,i)= &
16916                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16917                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16918                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16919       ! Bug fixed 3/24/05 (AL)
16920                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16921                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16922                   *vbld_inv(i-1+nres)
16923       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16924                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16925              enddo
16926       !   Obtaining the gamma derivatives from cosine derivative
16927             else
16928                do j=1,3
16929                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16930                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16931                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16932                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16933                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16934                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16935                dcosomicron(j,1,1,i)
16936                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16937                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16938                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16939                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16940                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16941       !          write(iout,*) "else",i
16942              enddo
16943             endif
16944             enddo
16945
16946 #ifdef CRYST_SC
16947       !   Derivatives of side-chain angles alpha and omega
16948 #if defined(MPI) && defined(PARINTDER)
16949             do i=ibond_start,ibond_end
16950 #else
16951             do i=2,nres-1
16952 #endif
16953               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16954                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16955                  fac6=fac5/vbld(i)
16956                  fac7=fac5*fac5
16957                  fac8=fac5/vbld(i+1)
16958                  fac9=fac5/vbld(i+nres)
16959                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16960                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16961                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16962                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16963                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16964                  sina=sqrt(1-cosa*cosa)
16965                  sino=dsin(omeg(i))
16966       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16967                  do j=1,3
16968                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16969                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16970                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16971                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16972                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16973                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16974                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16975                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16976                   vbld(i+nres))
16977                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16978                 enddo
16979       ! obtaining the derivatives of omega from sines
16980                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16981                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16982                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16983                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16984                    dsin(theta(i+1)))
16985                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16986                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16987                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16988                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16989                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16990                    coso_inv=1.0d0/dcos(omeg(i))
16991                    do j=1,3
16992                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16993                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16994                    (sino*dc_norm(j,i-1))/vbld(i)
16995                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16996                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16997                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16998                    -sino*dc_norm(j,i)/vbld(i+1)
16999                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17000                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17001                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17002                    vbld(i+nres)
17003                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17004                   enddo
17005                else
17006       !   obtaining the derivatives of omega from cosines
17007                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17008                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17009                  fac12=fac10*sina
17010                  fac13=fac12*fac12
17011                  fac14=sina*sina
17012                  do j=1,3
17013                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17014                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17015                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17016                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17017                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17018                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17019                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17020                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17021                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17022                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17023                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17024                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17025                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17026                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17027                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17028                 enddo
17029               endif
17030              else
17031                do j=1,3
17032                  do k=1,3
17033                    dalpha(k,j,i)=0.0d0
17034                    domega(k,j,i)=0.0d0
17035                  enddo
17036                enddo
17037              endif
17038              enddo
17039 #endif
17040 #if defined(MPI) && defined(PARINTDER)
17041             if (nfgtasks.gt.1) then
17042 #ifdef DEBUG
17043       !d      write (iout,*) "Gather dtheta"
17044       !d      call flush(iout)
17045             write (iout,*) "dtheta before gather"
17046             do i=1,nres
17047             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17048             enddo
17049 #endif
17050             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17051             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17052             king,FG_COMM,IERROR)
17053 #ifdef DEBUG
17054       !d      write (iout,*) "Gather dphi"
17055       !d      call flush(iout)
17056             write (iout,*) "dphi before gather"
17057             do i=1,nres
17058             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17059             enddo
17060 #endif
17061             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17062             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17063             king,FG_COMM,IERROR)
17064       !d      write (iout,*) "Gather dalpha"
17065       !d      call flush(iout)
17066 #ifdef CRYST_SC
17067             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17068             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17069             king,FG_COMM,IERROR)
17070       !d      write (iout,*) "Gather domega"
17071       !d      call flush(iout)
17072             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17073             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17074             king,FG_COMM,IERROR)
17075 #endif
17076             endif
17077 #endif
17078 #ifdef DEBUG
17079             write (iout,*) "dtheta after gather"
17080             do i=1,nres
17081             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17082             enddo
17083             write (iout,*) "dphi after gather"
17084             do i=1,nres
17085             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17086             enddo
17087             write (iout,*) "dalpha after gather"
17088             do i=1,nres
17089             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17090             enddo
17091             write (iout,*) "domega after gather"
17092             do i=1,nres
17093             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17094             enddo
17095 #endif
17096             return
17097             end subroutine intcartderiv
17098       !-----------------------------------------------------------------------------
17099             subroutine checkintcartgrad
17100       !      implicit real*8 (a-h,o-z)
17101       !      include 'DIMENSIONS'
17102 #ifdef MPI
17103             include 'mpif.h'
17104 #endif
17105       !      include 'COMMON.CHAIN'
17106       !      include 'COMMON.VAR'
17107       !      include 'COMMON.GEO'
17108       !      include 'COMMON.INTERACT'
17109       !      include 'COMMON.DERIV'
17110       !      include 'COMMON.IOUNITS'
17111       !      include 'COMMON.SETUP'
17112             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17113             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17114             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17115             real(kind=8),dimension(3) :: dc_norm_s
17116             real(kind=8) :: aincr=1.0d-5
17117             integer :: i,j
17118             real(kind=8) :: dcji
17119             do i=1,nres
17120             phi_s(i)=phi(i)
17121             theta_s(i)=theta(i)
17122             alph_s(i)=alph(i)
17123             omeg_s(i)=omeg(i)
17124             enddo
17125       ! Check theta gradient
17126             write (iout,*) &
17127              "Analytical (upper) and numerical (lower) gradient of theta"
17128             write (iout,*)
17129             do i=3,nres
17130             do j=1,3
17131               dcji=dc(j,i-2)
17132               dc(j,i-2)=dcji+aincr
17133               call chainbuild_cart
17134               call int_from_cart1(.false.)
17135           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17136           dc(j,i-2)=dcji
17137           dcji=dc(j,i-1)
17138           dc(j,i-1)=dc(j,i-1)+aincr
17139           call chainbuild_cart
17140           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17141           dc(j,i-1)=dcji
17142         enddo
17143 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17144 !el          (dtheta(j,2,i),j=1,3)
17145 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17146 !el          (dthetanum(j,2,i),j=1,3)
17147 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17148 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17149 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17150 !el        write (iout,*)
17151       enddo
17152 ! Check gamma gradient
17153       write (iout,*) &
17154        "Analytical (upper) and numerical (lower) gradient of gamma"
17155       do i=4,nres
17156         do j=1,3
17157           dcji=dc(j,i-3)
17158           dc(j,i-3)=dcji+aincr
17159           call chainbuild_cart
17160           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17161               dc(j,i-3)=dcji
17162           dcji=dc(j,i-2)
17163           dc(j,i-2)=dcji+aincr
17164           call chainbuild_cart
17165           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17166           dc(j,i-2)=dcji
17167           dcji=dc(j,i-1)
17168           dc(j,i-1)=dc(j,i-1)+aincr
17169           call chainbuild_cart
17170           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17171           dc(j,i-1)=dcji
17172         enddo
17173 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17174 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17175 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17176 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17177 !el        write (iout,'(5x,3(3f10.5,5x))') &
17178 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17179 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17180 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17181 !el        write (iout,*)
17182       enddo
17183 ! Check alpha gradient
17184       write (iout,*) &
17185        "Analytical (upper) and numerical (lower) gradient of alpha"
17186       do i=2,nres-1
17187        if(itype(i,1).ne.10) then
17188                  do j=1,3
17189                   dcji=dc(j,i-1)
17190                    dc(j,i-1)=dcji+aincr
17191               call chainbuild_cart
17192               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17193                  /aincr
17194                   dc(j,i-1)=dcji
17195               dcji=dc(j,i)
17196               dc(j,i)=dcji+aincr
17197               call chainbuild_cart
17198               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17199                  /aincr
17200               dc(j,i)=dcji
17201               dcji=dc(j,i+nres)
17202               dc(j,i+nres)=dc(j,i+nres)+aincr
17203               call chainbuild_cart
17204               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17205                  /aincr
17206              dc(j,i+nres)=dcji
17207             enddo
17208           endif
17209 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17210 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17211 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17212 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17213 !el        write (iout,'(5x,3(3f10.5,5x))') &
17214 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17215 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17216 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17217 !el        write (iout,*)
17218       enddo
17219 !     Check omega gradient
17220       write (iout,*) &
17221        "Analytical (upper) and numerical (lower) gradient of omega"
17222       do i=2,nres-1
17223        if(itype(i,1).ne.10) then
17224                  do j=1,3
17225                   dcji=dc(j,i-1)
17226                    dc(j,i-1)=dcji+aincr
17227               call chainbuild_cart
17228               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17229                  /aincr
17230                   dc(j,i-1)=dcji
17231               dcji=dc(j,i)
17232               dc(j,i)=dcji+aincr
17233               call chainbuild_cart
17234               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17235                  /aincr
17236               dc(j,i)=dcji
17237               dcji=dc(j,i+nres)
17238               dc(j,i+nres)=dc(j,i+nres)+aincr
17239               call chainbuild_cart
17240               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17241                  /aincr
17242              dc(j,i+nres)=dcji
17243             enddo
17244           endif
17245 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17246 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17247 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17248 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17249 !el        write (iout,'(5x,3(3f10.5,5x))') &
17250 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17251 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17252 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17253 !el        write (iout,*)
17254       enddo
17255       return
17256       end subroutine checkintcartgrad
17257 !-----------------------------------------------------------------------------
17258 ! q_measure.F
17259 !-----------------------------------------------------------------------------
17260       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17261 !      implicit real*8 (a-h,o-z)
17262 !      include 'DIMENSIONS'
17263 !      include 'COMMON.IOUNITS'
17264 !      include 'COMMON.CHAIN'
17265 !      include 'COMMON.INTERACT'
17266 !      include 'COMMON.VAR'
17267       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17268       integer :: kkk,nsep=3
17269       real(kind=8) :: qm      !dist,
17270       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17271       logical :: lprn=.false.
17272       logical :: flag
17273 !      real(kind=8) :: sigm,x
17274
17275 !el      sigm(x)=0.25d0*x     ! local function
17276       qqmax=1.0d10
17277       do kkk=1,nperm
17278       qq = 0.0d0
17279       nl=0
17280        if(flag) then
17281         do il=seg1+nsep,seg2
17282           do jl=seg1,il-nsep
17283             nl=nl+1
17284             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17285                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17286                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17287             dij=dist(il,jl)
17288             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17289             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17290               nl=nl+1
17291               d0ijCM=dsqrt( &
17292                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17293                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17294                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17295               dijCM=dist(il+nres,jl+nres)
17296               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17297             endif
17298             qq = qq+qqij+qqijCM
17299           enddo
17300         enddo
17301         qq = qq/nl
17302       else
17303       do il=seg1,seg2
17304         if((seg3-il).lt.3) then
17305              secseg=il+3
17306         else
17307              secseg=seg3
17308         endif
17309           do jl=secseg,seg4
17310             nl=nl+1
17311             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17312                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17313                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17314             dij=dist(il,jl)
17315             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17316             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17317               nl=nl+1
17318               d0ijCM=dsqrt( &
17319                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17320                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17321                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17322               dijCM=dist(il+nres,jl+nres)
17323               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17324             endif
17325             qq = qq+qqij+qqijCM
17326           enddo
17327         enddo
17328       qq = qq/nl
17329       endif
17330       if (qqmax.le.qq) qqmax=qq
17331       enddo
17332       qwolynes=1.0d0-qqmax
17333       return
17334       end function qwolynes
17335 !-----------------------------------------------------------------------------
17336       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17337 !      implicit real*8 (a-h,o-z)
17338 !      include 'DIMENSIONS'
17339 !      include 'COMMON.IOUNITS'
17340 !      include 'COMMON.CHAIN'
17341 !      include 'COMMON.INTERACT'
17342 !      include 'COMMON.VAR'
17343 !      include 'COMMON.MD'
17344       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17345       integer :: nsep=3, kkk
17346 !el      real(kind=8) :: dist
17347       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17348       logical :: lprn=.false.
17349       logical :: flag
17350       real(kind=8) :: sim,dd0,fac,ddqij
17351 !el      sigm(x)=0.25d0*x           ! local function
17352       do kkk=1,nperm
17353       do i=0,nres
17354         do j=1,3
17355           dqwol(j,i)=0.0d0
17356           dxqwol(j,i)=0.0d0
17357         enddo
17358       enddo
17359       nl=0
17360        if(flag) then
17361         do il=seg1+nsep,seg2
17362           do jl=seg1,il-nsep
17363             nl=nl+1
17364             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17365                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17366                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17367             dij=dist(il,jl)
17368             sim = 1.0d0/sigm(d0ij)
17369             sim = sim*sim
17370             dd0 = dij-d0ij
17371             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17372           do k=1,3
17373               ddqij = (c(k,il)-c(k,jl))*fac
17374               dqwol(k,il)=dqwol(k,il)+ddqij
17375               dqwol(k,jl)=dqwol(k,jl)-ddqij
17376             enddo
17377
17378             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17379               nl=nl+1
17380               d0ijCM=dsqrt( &
17381                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17382                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17383                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17384               dijCM=dist(il+nres,jl+nres)
17385               sim = 1.0d0/sigm(d0ijCM)
17386               sim = sim*sim
17387               dd0=dijCM-d0ijCM
17388               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17389               do k=1,3
17390                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17391                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17392                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17393               enddo
17394             endif
17395           enddo
17396         enddo
17397        else
17398         do il=seg1,seg2
17399         if((seg3-il).lt.3) then
17400              secseg=il+3
17401         else
17402              secseg=seg3
17403         endif
17404           do jl=secseg,seg4
17405             nl=nl+1
17406             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17407                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17408                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17409             dij=dist(il,jl)
17410             sim = 1.0d0/sigm(d0ij)
17411             sim = sim*sim
17412             dd0 = dij-d0ij
17413             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17414             do k=1,3
17415               ddqij = (c(k,il)-c(k,jl))*fac
17416               dqwol(k,il)=dqwol(k,il)+ddqij
17417               dqwol(k,jl)=dqwol(k,jl)-ddqij
17418             enddo
17419             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17420               nl=nl+1
17421               d0ijCM=dsqrt( &
17422                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17423                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17424                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17425               dijCM=dist(il+nres,jl+nres)
17426               sim = 1.0d0/sigm(d0ijCM)
17427               sim=sim*sim
17428               dd0 = dijCM-d0ijCM
17429               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17430               do k=1,3
17431                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17432                dxqwol(k,il)=dxqwol(k,il)+ddqij
17433                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17434               enddo
17435             endif
17436           enddo
17437         enddo
17438       endif
17439       enddo
17440        do i=0,nres
17441          do j=1,3
17442            dqwol(j,i)=dqwol(j,i)/nl
17443            dxqwol(j,i)=dxqwol(j,i)/nl
17444          enddo
17445        enddo
17446       return
17447       end subroutine qwolynes_prim
17448 !-----------------------------------------------------------------------------
17449       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17450 !      implicit real*8 (a-h,o-z)
17451 !      include 'DIMENSIONS'
17452 !      include 'COMMON.IOUNITS'
17453 !      include 'COMMON.CHAIN'
17454 !      include 'COMMON.INTERACT'
17455 !      include 'COMMON.VAR'
17456       integer :: seg1,seg2,seg3,seg4
17457       logical :: flag
17458       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17459       real(kind=8),dimension(3,0:2*nres) :: cdummy
17460       real(kind=8) :: q1,q2
17461       real(kind=8) :: delta=1.0d-10
17462       integer :: i,j
17463
17464       do i=0,nres
17465         do j=1,3
17466           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17467           cdummy(j,i)=c(j,i)
17468           c(j,i)=c(j,i)+delta
17469           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17470           qwolan(j,i)=(q2-q1)/delta
17471           c(j,i)=cdummy(j,i)
17472         enddo
17473       enddo
17474       do i=0,nres
17475         do j=1,3
17476           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17477           cdummy(j,i+nres)=c(j,i+nres)
17478           c(j,i+nres)=c(j,i+nres)+delta
17479           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17480           qwolxan(j,i)=(q2-q1)/delta
17481           c(j,i+nres)=cdummy(j,i+nres)
17482         enddo
17483       enddo
17484 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17485 !      do i=0,nct
17486 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17487 !      enddo
17488 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17489 !      do i=0,nct
17490 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17491 !      enddo
17492       return
17493       end subroutine qwol_num
17494 !-----------------------------------------------------------------------------
17495       subroutine EconstrQ
17496 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17497 !      implicit real*8 (a-h,o-z)
17498 !      include 'DIMENSIONS'
17499 !      include 'COMMON.CONTROL'
17500 !      include 'COMMON.VAR'
17501 !      include 'COMMON.MD'
17502       use MD_data
17503 !#ifndef LANG0
17504 !      include 'COMMON.LANGEVIN'
17505 !#else
17506 !      include 'COMMON.LANGEVIN.lang0'
17507 !#endif
17508 !      include 'COMMON.CHAIN'
17509 !      include 'COMMON.DERIV'
17510 !      include 'COMMON.GEO'
17511 !      include 'COMMON.LOCAL'
17512 !      include 'COMMON.INTERACT'
17513 !      include 'COMMON.IOUNITS'
17514 !      include 'COMMON.NAMES'
17515 !      include 'COMMON.TIME1'
17516       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17517       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17518                    duconst,duxconst
17519       integer :: kstart,kend,lstart,lend,idummy
17520       real(kind=8) :: delta=1.0d-7
17521       integer :: i,j,k,ii
17522       do i=0,nres
17523          do j=1,3
17524             duconst(j,i)=0.0d0
17525             dudconst(j,i)=0.0d0
17526             duxconst(j,i)=0.0d0
17527             dudxconst(j,i)=0.0d0
17528          enddo
17529       enddo
17530       Uconst=0.0d0
17531       do i=1,nfrag
17532          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17533            idummy,idummy)
17534          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17535 ! Calculating the derivatives of Constraint energy with respect to Q
17536          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17537            qinfrag(i,iset))
17538 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17539 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17540 !         hmnum=(hm2-hm1)/delta
17541 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17542 !     &   qinfrag(i,iset))
17543 !         write(iout,*) "harmonicnum frag", hmnum
17544 ! Calculating the derivatives of Q with respect to cartesian coordinates
17545          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17546           idummy,idummy)
17547 !         write(iout,*) "dqwol "
17548 !         do ii=1,nres
17549 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17550 !         enddo
17551 !         write(iout,*) "dxqwol "
17552 !         do ii=1,nres
17553 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17554 !         enddo
17555 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17556 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17557 !     &  ,idummy,idummy)
17558 !  The gradients of Uconst in Cs
17559          do ii=0,nres
17560             do j=1,3
17561                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17562                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17563             enddo
17564          enddo
17565       enddo
17566       do i=1,npair
17567          kstart=ifrag(1,ipair(1,i,iset),iset)
17568          kend=ifrag(2,ipair(1,i,iset),iset)
17569          lstart=ifrag(1,ipair(2,i,iset),iset)
17570          lend=ifrag(2,ipair(2,i,iset),iset)
17571          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17572          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17573 !  Calculating dU/dQ
17574          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17575 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17576 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17577 !         hmnum=(hm2-hm1)/delta
17578 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17579 !     &   qinpair(i,iset))
17580 !         write(iout,*) "harmonicnum pair ", hmnum
17581 ! Calculating dQ/dXi
17582          call qwolynes_prim(kstart,kend,.false.,&
17583           lstart,lend)
17584 !         write(iout,*) "dqwol "
17585 !         do ii=1,nres
17586 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17587 !         enddo
17588 !         write(iout,*) "dxqwol "
17589 !         do ii=1,nres
17590 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17591 !        enddo
17592 ! Calculating numerical gradients
17593 !        call qwol_num(kstart,kend,.false.
17594 !     &  ,lstart,lend)
17595 ! The gradients of Uconst in Cs
17596          do ii=0,nres
17597             do j=1,3
17598                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17599                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17600             enddo
17601          enddo
17602       enddo
17603 !      write(iout,*) "Uconst inside subroutine ", Uconst
17604 ! Transforming the gradients from Cs to dCs for the backbone
17605       do i=0,nres
17606          do j=i+1,nres
17607            do k=1,3
17608              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17609            enddo
17610          enddo
17611       enddo
17612 !  Transforming the gradients from Cs to dCs for the side chains
17613       do i=1,nres
17614          do j=1,3
17615            dudxconst(j,i)=duxconst(j,i)
17616          enddo
17617       enddo
17618 !      write(iout,*) "dU/ddc backbone "
17619 !       do ii=0,nres
17620 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17621 !      enddo
17622 !      write(iout,*) "dU/ddX side chain "
17623 !      do ii=1,nres
17624 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17625 !      enddo
17626 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17627 !      call dEconstrQ_num
17628       return
17629       end subroutine EconstrQ
17630 !-----------------------------------------------------------------------------
17631       subroutine dEconstrQ_num
17632 ! Calculating numerical dUconst/ddc and dUconst/ddx
17633 !      implicit real*8 (a-h,o-z)
17634 !      include 'DIMENSIONS'
17635 !      include 'COMMON.CONTROL'
17636 !      include 'COMMON.VAR'
17637 !      include 'COMMON.MD'
17638       use MD_data
17639 !#ifndef LANG0
17640 !      include 'COMMON.LANGEVIN'
17641 !#else
17642 !      include 'COMMON.LANGEVIN.lang0'
17643 !#endif
17644 !      include 'COMMON.CHAIN'
17645 !      include 'COMMON.DERIV'
17646 !      include 'COMMON.GEO'
17647 !      include 'COMMON.LOCAL'
17648 !      include 'COMMON.INTERACT'
17649 !      include 'COMMON.IOUNITS'
17650 !      include 'COMMON.NAMES'
17651 !      include 'COMMON.TIME1'
17652       real(kind=8) :: uzap1,uzap2
17653       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17654       integer :: kstart,kend,lstart,lend,idummy
17655       real(kind=8) :: delta=1.0d-7
17656 !el local variables
17657       integer :: i,ii,j
17658 !     real(kind=8) ::
17659 !     For the backbone
17660       do i=0,nres-1
17661          do j=1,3
17662             dUcartan(j,i)=0.0d0
17663             cdummy(j,i)=dc(j,i)
17664             dc(j,i)=dc(j,i)+delta
17665             call chainbuild_cart
17666           uzap2=0.0d0
17667             do ii=1,nfrag
17668              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17669                 idummy,idummy)
17670                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17671                 qinfrag(ii,iset))
17672             enddo
17673             do ii=1,npair
17674                kstart=ifrag(1,ipair(1,ii,iset),iset)
17675                kend=ifrag(2,ipair(1,ii,iset),iset)
17676                lstart=ifrag(1,ipair(2,ii,iset),iset)
17677                lend=ifrag(2,ipair(2,ii,iset),iset)
17678                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17679                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17680                  qinpair(ii,iset))
17681             enddo
17682             dc(j,i)=cdummy(j,i)
17683             call chainbuild_cart
17684             uzap1=0.0d0
17685              do ii=1,nfrag
17686              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17687                 idummy,idummy)
17688                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17689                 qinfrag(ii,iset))
17690             enddo
17691             do ii=1,npair
17692                kstart=ifrag(1,ipair(1,ii,iset),iset)
17693                kend=ifrag(2,ipair(1,ii,iset),iset)
17694                lstart=ifrag(1,ipair(2,ii,iset),iset)
17695                lend=ifrag(2,ipair(2,ii,iset),iset)
17696                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17697                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17698                 qinpair(ii,iset))
17699             enddo
17700             ducartan(j,i)=(uzap2-uzap1)/(delta)
17701          enddo
17702       enddo
17703 ! Calculating numerical gradients for dU/ddx
17704       do i=0,nres-1
17705          duxcartan(j,i)=0.0d0
17706          do j=1,3
17707             cdummy(j,i)=dc(j,i+nres)
17708             dc(j,i+nres)=dc(j,i+nres)+delta
17709             call chainbuild_cart
17710           uzap2=0.0d0
17711             do ii=1,nfrag
17712              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17713                 idummy,idummy)
17714                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17715                 qinfrag(ii,iset))
17716             enddo
17717             do ii=1,npair
17718                kstart=ifrag(1,ipair(1,ii,iset),iset)
17719                kend=ifrag(2,ipair(1,ii,iset),iset)
17720                lstart=ifrag(1,ipair(2,ii,iset),iset)
17721                lend=ifrag(2,ipair(2,ii,iset),iset)
17722                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17723                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17724                 qinpair(ii,iset))
17725             enddo
17726             dc(j,i+nres)=cdummy(j,i)
17727             call chainbuild_cart
17728             uzap1=0.0d0
17729              do ii=1,nfrag
17730                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17731                 ifrag(2,ii,iset),.true.,idummy,idummy)
17732                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17733                 qinfrag(ii,iset))
17734             enddo
17735             do ii=1,npair
17736                kstart=ifrag(1,ipair(1,ii,iset),iset)
17737                kend=ifrag(2,ipair(1,ii,iset),iset)
17738                lstart=ifrag(1,ipair(2,ii,iset),iset)
17739                lend=ifrag(2,ipair(2,ii,iset),iset)
17740                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17741                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17742                 qinpair(ii,iset))
17743             enddo
17744             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17745          enddo
17746       enddo
17747       write(iout,*) "Numerical dUconst/ddc backbone "
17748       do ii=0,nres
17749         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17750       enddo
17751 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17752 !      do ii=1,nres
17753 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17754 !      enddo
17755       return
17756       end subroutine dEconstrQ_num
17757 !-----------------------------------------------------------------------------
17758 ! ssMD.F
17759 !-----------------------------------------------------------------------------
17760       subroutine check_energies
17761
17762 !      use random, only: ran_number
17763
17764 !      implicit none
17765 !     Includes
17766 !      include 'DIMENSIONS'
17767 !      include 'COMMON.CHAIN'
17768 !      include 'COMMON.VAR'
17769 !      include 'COMMON.IOUNITS'
17770 !      include 'COMMON.SBRIDGE'
17771 !      include 'COMMON.LOCAL'
17772 !      include 'COMMON.GEO'
17773
17774 !     External functions
17775 !EL      double precision ran_number
17776 !EL      external ran_number
17777
17778 !     Local variables
17779       integer :: i,j,k,l,lmax,p,pmax
17780       real(kind=8) :: rmin,rmax
17781       real(kind=8) :: eij
17782
17783       real(kind=8) :: d
17784       real(kind=8) :: wi,rij,tj,pj
17785 !      return
17786
17787       i=5
17788       j=14
17789
17790       d=dsc(1)
17791       rmin=2.0D0
17792       rmax=12.0D0
17793
17794       lmax=10000
17795       pmax=1
17796
17797       do k=1,3
17798         c(k,i)=0.0D0
17799         c(k,j)=0.0D0
17800         c(k,nres+i)=0.0D0
17801         c(k,nres+j)=0.0D0
17802       enddo
17803
17804       do l=1,lmax
17805
17806 !t        wi=ran_number(0.0D0,pi)
17807 !        wi=ran_number(0.0D0,pi/6.0D0)
17808 !        wi=0.0D0
17809 !t        tj=ran_number(0.0D0,pi)
17810 !t        pj=ran_number(0.0D0,pi)
17811 !        pj=ran_number(0.0D0,pi/6.0D0)
17812 !        pj=0.0D0
17813
17814         do p=1,pmax
17815 !t           rij=ran_number(rmin,rmax)
17816
17817            c(1,j)=d*sin(pj)*cos(tj)
17818            c(2,j)=d*sin(pj)*sin(tj)
17819            c(3,j)=d*cos(pj)
17820
17821            c(3,nres+i)=-rij
17822
17823            c(1,i)=d*sin(wi)
17824            c(3,i)=-rij-d*cos(wi)
17825
17826            do k=1,3
17827               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17828               dc_norm(k,nres+i)=dc(k,nres+i)/d
17829               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17830               dc_norm(k,nres+j)=dc(k,nres+j)/d
17831            enddo
17832
17833            call dyn_ssbond_ene(i,j,eij)
17834         enddo
17835       enddo
17836       call exit(1)
17837       return
17838       end subroutine check_energies
17839 !-----------------------------------------------------------------------------
17840       subroutine dyn_ssbond_ene(resi,resj,eij)
17841 !      implicit none
17842 !      Includes
17843       use calc_data
17844       use comm_sschecks
17845 !      include 'DIMENSIONS'
17846 !      include 'COMMON.SBRIDGE'
17847 !      include 'COMMON.CHAIN'
17848 !      include 'COMMON.DERIV'
17849 !      include 'COMMON.LOCAL'
17850 !      include 'COMMON.INTERACT'
17851 !      include 'COMMON.VAR'
17852 !      include 'COMMON.IOUNITS'
17853 !      include 'COMMON.CALC'
17854 #ifndef CLUST
17855 #ifndef WHAM
17856        use MD_data
17857 !      include 'COMMON.MD'
17858 !      use MD, only: totT,t_bath
17859 #endif
17860 #endif
17861 !     External functions
17862 !EL      double precision h_base
17863 !EL      external h_base
17864
17865 !     Input arguments
17866       integer :: resi,resj
17867
17868 !     Output arguments
17869       real(kind=8) :: eij
17870
17871 !     Local variables
17872       logical :: havebond
17873       integer itypi,itypj
17874       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17875       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17876       real(kind=8),dimension(3) :: dcosom1,dcosom2
17877       real(kind=8) :: ed
17878       real(kind=8) :: pom1,pom2
17879       real(kind=8) :: ljA,ljB,ljXs
17880       real(kind=8),dimension(1:3) :: d_ljB
17881       real(kind=8) :: ssA,ssB,ssC,ssXs
17882       real(kind=8) :: ssxm,ljxm,ssm,ljm
17883       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17884       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17885       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17886 !-------FIRST METHOD
17887       real(kind=8) :: xm
17888       real(kind=8),dimension(1:3) :: d_xm
17889 !-------END FIRST METHOD
17890 !-------SECOND METHOD
17891 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17892 !-------END SECOND METHOD
17893
17894 !-------TESTING CODE
17895 !el      logical :: checkstop,transgrad
17896 !el      common /sschecks/ checkstop,transgrad
17897
17898       integer :: icheck,nicheck,jcheck,njcheck
17899       real(kind=8),dimension(-1:1) :: echeck
17900       real(kind=8) :: deps,ssx0,ljx0
17901 !-------END TESTING CODE
17902
17903       eij=0.0d0
17904       i=resi
17905       j=resj
17906
17907 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17908 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17909
17910       itypi=itype(i,1)
17911       dxi=dc_norm(1,nres+i)
17912       dyi=dc_norm(2,nres+i)
17913       dzi=dc_norm(3,nres+i)
17914       dsci_inv=vbld_inv(i+nres)
17915
17916       itypj=itype(j,1)
17917       xj=c(1,nres+j)-c(1,nres+i)
17918       yj=c(2,nres+j)-c(2,nres+i)
17919       zj=c(3,nres+j)-c(3,nres+i)
17920       dxj=dc_norm(1,nres+j)
17921       dyj=dc_norm(2,nres+j)
17922       dzj=dc_norm(3,nres+j)
17923       dscj_inv=vbld_inv(j+nres)
17924
17925       chi1=chi(itypi,itypj)
17926       chi2=chi(itypj,itypi)
17927       chi12=chi1*chi2
17928       chip1=chip(itypi)
17929       chip2=chip(itypj)
17930       chip12=chip1*chip2
17931       alf1=alp(itypi)
17932       alf2=alp(itypj)
17933       alf12=0.5D0*(alf1+alf2)
17934
17935       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17936       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17937 !     The following are set in sc_angular
17938 !      erij(1)=xj*rij
17939 !      erij(2)=yj*rij
17940 !      erij(3)=zj*rij
17941 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17942 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17943 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17944       call sc_angular
17945       rij=1.0D0/rij  ! Reset this so it makes sense
17946
17947       sig0ij=sigma(itypi,itypj)
17948       sig=sig0ij*dsqrt(1.0D0/sigsq)
17949
17950       ljXs=sig-sig0ij
17951       ljA=eps1*eps2rt**2*eps3rt**2
17952       ljB=ljA*bb_aq(itypi,itypj)
17953       ljA=ljA*aa_aq(itypi,itypj)
17954       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17955
17956       ssXs=d0cm
17957       deltat1=1.0d0-om1
17958       deltat2=1.0d0+om2
17959       deltat12=om2-om1+2.0d0
17960       cosphi=om12-om1*om2
17961       ssA=akcm
17962       ssB=akct*deltat12
17963       ssC=ss_depth &
17964            +akth*(deltat1*deltat1+deltat2*deltat2) &
17965            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17966       ssxm=ssXs-0.5D0*ssB/ssA
17967
17968 !-------TESTING CODE
17969 !$$$c     Some extra output
17970 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17971 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17972 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17973 !$$$      if (ssx0.gt.0.0d0) then
17974 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17975 !$$$      else
17976 !$$$        ssx0=ssxm
17977 !$$$      endif
17978 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17979 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17980 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17981 !$$$      return
17982 !-------END TESTING CODE
17983
17984 !-------TESTING CODE
17985 !     Stop and plot energy and derivative as a function of distance
17986       if (checkstop) then
17987         ssm=ssC-0.25D0*ssB*ssB/ssA
17988         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17989         if (ssm.lt.ljm .and. &
17990              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17991           nicheck=1000
17992           njcheck=1
17993           deps=0.5d-7
17994         else
17995           checkstop=.false.
17996         endif
17997       endif
17998       if (.not.checkstop) then
17999         nicheck=0
18000         njcheck=-1
18001       endif
18002
18003       do icheck=0,nicheck
18004       do jcheck=-1,njcheck
18005       if (checkstop) rij=(ssxm-1.0d0)+ &
18006              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18007 !-------END TESTING CODE
18008
18009       if (rij.gt.ljxm) then
18010         havebond=.false.
18011         ljd=rij-ljXs
18012         fac=(1.0D0/ljd)**expon
18013         e1=fac*fac*aa_aq(itypi,itypj)
18014         e2=fac*bb_aq(itypi,itypj)
18015         eij=eps1*eps2rt*eps3rt*(e1+e2)
18016         eps2der=eij*eps3rt
18017         eps3der=eij*eps2rt
18018         eij=eij*eps2rt*eps3rt
18019
18020         sigder=-sig/sigsq
18021         e1=e1*eps1*eps2rt**2*eps3rt**2
18022         ed=-expon*(e1+eij)/ljd
18023         sigder=ed*sigder
18024         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18025         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18026         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18027              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18028       else if (rij.lt.ssxm) then
18029         havebond=.true.
18030         ssd=rij-ssXs
18031         eij=ssA*ssd*ssd+ssB*ssd+ssC
18032
18033         ed=2*akcm*ssd+akct*deltat12
18034         pom1=akct*ssd
18035         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18036         eom1=-2*akth*deltat1-pom1-om2*pom2
18037         eom2= 2*akth*deltat2+pom1-om1*pom2
18038         eom12=pom2
18039       else
18040         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18041
18042         d_ssxm(1)=0.5D0*akct/ssA
18043         d_ssxm(2)=-d_ssxm(1)
18044         d_ssxm(3)=0.0D0
18045
18046         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18047         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18048         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18049         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18050
18051 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18052         xm=0.5d0*(ssxm+ljxm)
18053         do k=1,3
18054           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18055         enddo
18056         if (rij.lt.xm) then
18057           havebond=.true.
18058           ssm=ssC-0.25D0*ssB*ssB/ssA
18059           d_ssm(1)=0.5D0*akct*ssB/ssA
18060           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18061           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18062           d_ssm(3)=omega
18063           f1=(rij-xm)/(ssxm-xm)
18064           f2=(rij-ssxm)/(xm-ssxm)
18065           h1=h_base(f1,hd1)
18066           h2=h_base(f2,hd2)
18067           eij=ssm*h1+Ht*h2
18068           delta_inv=1.0d0/(xm-ssxm)
18069           deltasq_inv=delta_inv*delta_inv
18070           fac=ssm*hd1-Ht*hd2
18071           fac1=deltasq_inv*fac*(xm-rij)
18072           fac2=deltasq_inv*fac*(rij-ssxm)
18073           ed=delta_inv*(Ht*hd2-ssm*hd1)
18074           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18075           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18076           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18077         else
18078           havebond=.false.
18079           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18080           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18081           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18082           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18083                alf12/eps3rt)
18084           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18085           f1=(rij-ljxm)/(xm-ljxm)
18086           f2=(rij-xm)/(ljxm-xm)
18087           h1=h_base(f1,hd1)
18088           h2=h_base(f2,hd2)
18089           eij=Ht*h1+ljm*h2
18090           delta_inv=1.0d0/(ljxm-xm)
18091           deltasq_inv=delta_inv*delta_inv
18092           fac=Ht*hd1-ljm*hd2
18093           fac1=deltasq_inv*fac*(ljxm-rij)
18094           fac2=deltasq_inv*fac*(rij-xm)
18095           ed=delta_inv*(ljm*hd2-Ht*hd1)
18096           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18097           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18098           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18099         endif
18100 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18101
18102 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18103 !$$$        ssd=rij-ssXs
18104 !$$$        ljd=rij-ljXs
18105 !$$$        fac1=rij-ljxm
18106 !$$$        fac2=rij-ssxm
18107 !$$$
18108 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18109 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18110 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18111 !$$$
18112 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18113 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18114 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18115 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18116 !$$$        d_ssm(3)=omega
18117 !$$$
18118 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18119 !$$$        do k=1,3
18120 !$$$          d_ljm(k)=ljm*d_ljB(k)
18121 !$$$        enddo
18122 !$$$        ljm=ljm*ljB
18123 !$$$
18124 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18125 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18126 !$$$        d_ss(2)=akct*ssd
18127 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18128 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18129 !$$$        d_ss(3)=omega
18130 !$$$
18131 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18132 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18133 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18134 !$$$        do k=1,3
18135 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18136 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18137 !$$$        enddo
18138 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18139 !$$$
18140 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18141 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18142 !$$$        h1=h_base(f1,hd1)
18143 !$$$        h2=h_base(f2,hd2)
18144 !$$$        eij=ss*h1+ljf*h2
18145 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18146 !$$$        deltasq_inv=delta_inv*delta_inv
18147 !$$$        fac=ljf*hd2-ss*hd1
18148 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18149 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18150 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18151 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18152 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18153 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18154 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18155 !$$$
18156 !$$$        havebond=.false.
18157 !$$$        if (ed.gt.0.0d0) havebond=.true.
18158 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18159
18160       endif
18161
18162       if (havebond) then
18163 !#ifndef CLUST
18164 !#ifndef WHAM
18165 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18166 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18167 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18168 !        endif
18169 !#endif
18170 !#endif
18171         dyn_ssbond_ij(i,j)=eij
18172       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18173         dyn_ssbond_ij(i,j)=1.0d300
18174 !#ifndef CLUST
18175 !#ifndef WHAM
18176 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18177 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18178 !#endif
18179 !#endif
18180       endif
18181
18182 !-------TESTING CODE
18183 !el      if (checkstop) then
18184         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18185              "CHECKSTOP",rij,eij,ed
18186         echeck(jcheck)=eij
18187 !el      endif
18188       enddo
18189       if (checkstop) then
18190         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18191       endif
18192       enddo
18193       if (checkstop) then
18194         transgrad=.true.
18195         checkstop=.false.
18196       endif
18197 !-------END TESTING CODE
18198
18199       do k=1,3
18200         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18201         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18202       enddo
18203       do k=1,3
18204         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18205       enddo
18206       do k=1,3
18207         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18208              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18209              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18210         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18211              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18212              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18213       enddo
18214 !grad      do k=i,j-1
18215 !grad        do l=1,3
18216 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18217 !grad        enddo
18218 !grad      enddo
18219
18220       do l=1,3
18221         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18222         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18223       enddo
18224
18225       return
18226       end subroutine dyn_ssbond_ene
18227 !--------------------------------------------------------------------------
18228          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18229 !      implicit none
18230 !      Includes
18231       use calc_data
18232       use comm_sschecks
18233 !      include 'DIMENSIONS'
18234 !      include 'COMMON.SBRIDGE'
18235 !      include 'COMMON.CHAIN'
18236 !      include 'COMMON.DERIV'
18237 !      include 'COMMON.LOCAL'
18238 !      include 'COMMON.INTERACT'
18239 !      include 'COMMON.VAR'
18240 !      include 'COMMON.IOUNITS'
18241 !      include 'COMMON.CALC'
18242 #ifndef CLUST
18243 #ifndef WHAM
18244        use MD_data
18245 !      include 'COMMON.MD'
18246 !      use MD, only: totT,t_bath
18247 #endif
18248 #endif
18249       double precision h_base
18250       external h_base
18251
18252 !c     Input arguments
18253       integer resi,resj,resk,m,itypi,itypj,itypk
18254
18255 !c     Output arguments
18256       double precision eij,eij1,eij2,eij3
18257
18258 !c     Local variables
18259       logical havebond
18260 !c      integer itypi,itypj,k,l
18261       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18262       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18263       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18264       double precision sig0ij,ljd,sig,fac,e1,e2
18265       double precision dcosom1(3),dcosom2(3),ed
18266       double precision pom1,pom2
18267       double precision ljA,ljB,ljXs
18268       double precision d_ljB(1:3)
18269       double precision ssA,ssB,ssC,ssXs
18270       double precision ssxm,ljxm,ssm,ljm
18271       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18272       eij=0.0
18273       if (dtriss.eq.0) return
18274       i=resi
18275       j=resj
18276       k=resk
18277 !C      write(iout,*) resi,resj,resk
18278       itypi=itype(i,1)
18279       dxi=dc_norm(1,nres+i)
18280       dyi=dc_norm(2,nres+i)
18281       dzi=dc_norm(3,nres+i)
18282       dsci_inv=vbld_inv(i+nres)
18283       xi=c(1,nres+i)
18284       yi=c(2,nres+i)
18285       zi=c(3,nres+i)
18286       itypj=itype(j,1)
18287       xj=c(1,nres+j)
18288       yj=c(2,nres+j)
18289       zj=c(3,nres+j)
18290
18291       dxj=dc_norm(1,nres+j)
18292       dyj=dc_norm(2,nres+j)
18293       dzj=dc_norm(3,nres+j)
18294       dscj_inv=vbld_inv(j+nres)
18295       itypk=itype(k,1)
18296       xk=c(1,nres+k)
18297       yk=c(2,nres+k)
18298       zk=c(3,nres+k)
18299
18300       dxk=dc_norm(1,nres+k)
18301       dyk=dc_norm(2,nres+k)
18302       dzk=dc_norm(3,nres+k)
18303       dscj_inv=vbld_inv(k+nres)
18304       xij=xj-xi
18305       xik=xk-xi
18306       xjk=xk-xj
18307       yij=yj-yi
18308       yik=yk-yi
18309       yjk=yk-yj
18310       zij=zj-zi
18311       zik=zk-zi
18312       zjk=zk-zj
18313       rrij=(xij*xij+yij*yij+zij*zij)
18314       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18315       rrik=(xik*xik+yik*yik+zik*zik)
18316       rik=dsqrt(rrik)
18317       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18318       rjk=dsqrt(rrjk)
18319 !C there are three combination of distances for each trisulfide bonds
18320 !C The first case the ith atom is the center
18321 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18322 !C distance y is second distance the a,b,c,d are parameters derived for
18323 !C this problem d parameter was set as a penalty currenlty set to 1.
18324       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18325       eij1=0.0d0
18326       else
18327       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18328       endif
18329 !C second case jth atom is center
18330       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18331       eij2=0.0d0
18332       else
18333       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18334       endif
18335 !C the third case kth atom is the center
18336       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18337       eij3=0.0d0
18338       else
18339       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18340       endif
18341 !C      eij2=0.0
18342 !C      eij3=0.0
18343 !C      eij1=0.0
18344       eij=eij1+eij2+eij3
18345 !C      write(iout,*)i,j,k,eij
18346 !C The energy penalty calculated now time for the gradient part
18347 !C derivative over rij
18348       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18349       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18350             gg(1)=xij*fac/rij
18351             gg(2)=yij*fac/rij
18352             gg(3)=zij*fac/rij
18353       do m=1,3
18354         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18355         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18356       enddo
18357
18358       do l=1,3
18359         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18360         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18361       enddo
18362 !C now derivative over rik
18363       fac=-eij1**2/dtriss* &
18364       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18365       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18366             gg(1)=xik*fac/rik
18367             gg(2)=yik*fac/rik
18368             gg(3)=zik*fac/rik
18369       do m=1,3
18370         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18371         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18372       enddo
18373       do l=1,3
18374         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18375         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18376       enddo
18377 !C now derivative over rjk
18378       fac=-eij2**2/dtriss* &
18379       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18380       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18381             gg(1)=xjk*fac/rjk
18382             gg(2)=yjk*fac/rjk
18383             gg(3)=zjk*fac/rjk
18384       do m=1,3
18385         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18386         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18387       enddo
18388       do l=1,3
18389         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18390         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18391       enddo
18392       return
18393       end subroutine triple_ssbond_ene
18394
18395
18396
18397 !-----------------------------------------------------------------------------
18398       real(kind=8) function h_base(x,deriv)
18399 !     A smooth function going 0->1 in range [0,1]
18400 !     It should NOT be called outside range [0,1], it will not work there.
18401       implicit none
18402
18403 !     Input arguments
18404       real(kind=8) :: x
18405
18406 !     Output arguments
18407       real(kind=8) :: deriv
18408
18409 !     Local variables
18410       real(kind=8) :: xsq
18411
18412
18413 !     Two parabolas put together.  First derivative zero at extrema
18414 !$$$      if (x.lt.0.5D0) then
18415 !$$$        h_base=2.0D0*x*x
18416 !$$$        deriv=4.0D0*x
18417 !$$$      else
18418 !$$$        deriv=1.0D0-x
18419 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18420 !$$$        deriv=4.0D0*deriv
18421 !$$$      endif
18422
18423 !     Third degree polynomial.  First derivative zero at extrema
18424       h_base=x*x*(3.0d0-2.0d0*x)
18425       deriv=6.0d0*x*(1.0d0-x)
18426
18427 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18428 !$$$      xsq=x*x
18429 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18430 !$$$      deriv=x-1.0d0
18431 !$$$      deriv=deriv*deriv
18432 !$$$      deriv=30.0d0*xsq*deriv
18433
18434       return
18435       end function h_base
18436 !-----------------------------------------------------------------------------
18437       subroutine dyn_set_nss
18438 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18439 !      implicit none
18440       use MD_data, only: totT,t_bath
18441 !     Includes
18442 !      include 'DIMENSIONS'
18443 #ifdef MPI
18444       include "mpif.h"
18445 #endif
18446 !      include 'COMMON.SBRIDGE'
18447 !      include 'COMMON.CHAIN'
18448 !      include 'COMMON.IOUNITS'
18449 !      include 'COMMON.SETUP'
18450 !      include 'COMMON.MD'
18451 !     Local variables
18452       real(kind=8) :: emin
18453       integer :: i,j,imin,ierr
18454       integer :: diff,allnss,newnss
18455       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18456                 newihpb,newjhpb
18457       logical :: found
18458       integer,dimension(0:nfgtasks) :: i_newnss
18459       integer,dimension(0:nfgtasks) :: displ
18460       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18461       integer :: g_newnss
18462
18463       allnss=0
18464       do i=1,nres-1
18465         do j=i+1,nres
18466           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18467             allnss=allnss+1
18468             allflag(allnss)=0
18469             allihpb(allnss)=i
18470             alljhpb(allnss)=j
18471           endif
18472         enddo
18473       enddo
18474
18475 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18476
18477  1    emin=1.0d300
18478       do i=1,allnss
18479         if (allflag(i).eq.0 .and. &
18480              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18481           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18482           imin=i
18483         endif
18484       enddo
18485       if (emin.lt.1.0d300) then
18486         allflag(imin)=1
18487         do i=1,allnss
18488           if (allflag(i).eq.0 .and. &
18489                (allihpb(i).eq.allihpb(imin) .or. &
18490                alljhpb(i).eq.allihpb(imin) .or. &
18491                allihpb(i).eq.alljhpb(imin) .or. &
18492                alljhpb(i).eq.alljhpb(imin))) then
18493             allflag(i)=-1
18494           endif
18495         enddo
18496         goto 1
18497       endif
18498
18499 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18500
18501       newnss=0
18502       do i=1,allnss
18503         if (allflag(i).eq.1) then
18504           newnss=newnss+1
18505           newihpb(newnss)=allihpb(i)
18506           newjhpb(newnss)=alljhpb(i)
18507         endif
18508       enddo
18509
18510 #ifdef MPI
18511       if (nfgtasks.gt.1)then
18512
18513         call MPI_Reduce(newnss,g_newnss,1,&
18514           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18515         call MPI_Gather(newnss,1,MPI_INTEGER,&
18516                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18517         displ(0)=0
18518         do i=1,nfgtasks-1,1
18519           displ(i)=i_newnss(i-1)+displ(i-1)
18520         enddo
18521         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18522                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18523                          king,FG_COMM,IERR)
18524         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18525                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18526                          king,FG_COMM,IERR)
18527         if(fg_rank.eq.0) then
18528 !         print *,'g_newnss',g_newnss
18529 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18530 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18531          newnss=g_newnss
18532          do i=1,newnss
18533           newihpb(i)=g_newihpb(i)
18534           newjhpb(i)=g_newjhpb(i)
18535          enddo
18536         endif
18537       endif
18538 #endif
18539
18540       diff=newnss-nss
18541
18542 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18543 !       print *,newnss,nss,maxdim
18544       do i=1,nss
18545         found=.false.
18546 !        print *,newnss
18547         do j=1,newnss
18548 !!          print *,j
18549           if (idssb(i).eq.newihpb(j) .and. &
18550                jdssb(i).eq.newjhpb(j)) found=.true.
18551         enddo
18552 #ifndef CLUST
18553 #ifndef WHAM
18554 !        write(iout,*) "found",found,i,j
18555         if (.not.found.and.fg_rank.eq.0) &
18556             write(iout,'(a15,f12.2,f8.1,2i5)') &
18557              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18558 #endif
18559 #endif
18560       enddo
18561
18562       do i=1,newnss
18563         found=.false.
18564         do j=1,nss
18565 !          print *,i,j
18566           if (newihpb(i).eq.idssb(j) .and. &
18567                newjhpb(i).eq.jdssb(j)) found=.true.
18568         enddo
18569 #ifndef CLUST
18570 #ifndef WHAM
18571 !        write(iout,*) "found",found,i,j
18572         if (.not.found.and.fg_rank.eq.0) &
18573             write(iout,'(a15,f12.2,f8.1,2i5)') &
18574              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18575 #endif
18576 #endif
18577       enddo
18578
18579       nss=newnss
18580       do i=1,nss
18581         idssb(i)=newihpb(i)
18582         jdssb(i)=newjhpb(i)
18583       enddo
18584
18585       return
18586       end subroutine dyn_set_nss
18587 ! Lipid transfer energy function
18588       subroutine Eliptransfer(eliptran)
18589 !C this is done by Adasko
18590 !C      print *,"wchodze"
18591 !C structure of box:
18592 !C      water
18593 !C--bordliptop-- buffore starts
18594 !C--bufliptop--- here true lipid starts
18595 !C      lipid
18596 !C--buflipbot--- lipid ends buffore starts
18597 !C--bordlipbot--buffore ends
18598       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18599       integer :: i
18600       eliptran=0.0
18601 !      print *, "I am in eliptran"
18602       do i=ilip_start,ilip_end
18603 !C       do i=1,1
18604         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18605          cycle
18606
18607         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18608         if (positi.le.0.0) positi=positi+boxzsize
18609 !C        print *,i
18610 !C first for peptide groups
18611 !c for each residue check if it is in lipid or lipid water border area
18612        if ((positi.gt.bordlipbot)  &
18613       .and.(positi.lt.bordliptop)) then
18614 !C the energy transfer exist
18615         if (positi.lt.buflipbot) then
18616 !C what fraction I am in
18617          fracinbuf=1.0d0-      &
18618              ((positi-bordlipbot)/lipbufthick)
18619 !C lipbufthick is thickenes of lipid buffore
18620          sslip=sscalelip(fracinbuf)
18621          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18622          eliptran=eliptran+sslip*pepliptran
18623          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18624          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18625 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18626
18627 !C        print *,"doing sccale for lower part"
18628 !C         print *,i,sslip,fracinbuf,ssgradlip
18629         elseif (positi.gt.bufliptop) then
18630          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18631          sslip=sscalelip(fracinbuf)
18632          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18633          eliptran=eliptran+sslip*pepliptran
18634          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18635          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18636 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18637 !C          print *, "doing sscalefor top part"
18638 !C         print *,i,sslip,fracinbuf,ssgradlip
18639         else
18640          eliptran=eliptran+pepliptran
18641 !C         print *,"I am in true lipid"
18642         endif
18643 !C       else
18644 !C       eliptran=elpitran+0.0 ! I am in water
18645        endif
18646        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18647        enddo
18648 ! here starts the side chain transfer
18649        do i=ilip_start,ilip_end
18650         if (itype(i,1).eq.ntyp1) cycle
18651         positi=(mod(c(3,i+nres),boxzsize))
18652         if (positi.le.0) positi=positi+boxzsize
18653 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18654 !c for each residue check if it is in lipid or lipid water border area
18655 !C       respos=mod(c(3,i+nres),boxzsize)
18656 !C       print *,positi,bordlipbot,buflipbot
18657        if ((positi.gt.bordlipbot) &
18658        .and.(positi.lt.bordliptop)) then
18659 !C the energy transfer exist
18660         if (positi.lt.buflipbot) then
18661          fracinbuf=1.0d0-   &
18662            ((positi-bordlipbot)/lipbufthick)
18663 !C lipbufthick is thickenes of lipid buffore
18664          sslip=sscalelip(fracinbuf)
18665          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18666          eliptran=eliptran+sslip*liptranene(itype(i,1))
18667          gliptranx(3,i)=gliptranx(3,i) &
18668       +ssgradlip*liptranene(itype(i,1))
18669          gliptranc(3,i-1)= gliptranc(3,i-1) &
18670       +ssgradlip*liptranene(itype(i,1))
18671 !C         print *,"doing sccale for lower part"
18672         elseif (positi.gt.bufliptop) then
18673          fracinbuf=1.0d0-  &
18674       ((bordliptop-positi)/lipbufthick)
18675          sslip=sscalelip(fracinbuf)
18676          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18677          eliptran=eliptran+sslip*liptranene(itype(i,1))
18678          gliptranx(3,i)=gliptranx(3,i)  &
18679        +ssgradlip*liptranene(itype(i,1))
18680          gliptranc(3,i-1)= gliptranc(3,i-1) &
18681       +ssgradlip*liptranene(itype(i,1))
18682 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18683         else
18684          eliptran=eliptran+liptranene(itype(i,1))
18685 !C         print *,"I am in true lipid"
18686         endif
18687         endif ! if in lipid or buffor
18688 !C       else
18689 !C       eliptran=elpitran+0.0 ! I am in water
18690         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18691        enddo
18692        return
18693        end  subroutine Eliptransfer
18694 !----------------------------------NANO FUNCTIONS
18695 !C-----------------------------------------------------------------------
18696 !C-----------------------------------------------------------
18697 !C This subroutine is to mimic the histone like structure but as well can be
18698 !C utilizet to nanostructures (infinit) small modification has to be used to
18699 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18700 !C gradient has to be modified at the ends
18701 !C The energy function is Kihara potential
18702 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18703 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18704 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18705 !C simple Kihara potential
18706       subroutine calctube(Etube)
18707       real(kind=8),dimension(3) :: vectube
18708       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18709        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18710        sc_aa_tube,sc_bb_tube
18711       integer :: i,j,iti
18712       Etube=0.0d0
18713       do i=itube_start,itube_end
18714         enetube(i)=0.0d0
18715         enetube(i+nres)=0.0d0
18716       enddo
18717 !C first we calculate the distance from tube center
18718 !C for UNRES
18719        do i=itube_start,itube_end
18720 !C lets ommit dummy atoms for now
18721        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18722 !C now calculate distance from center of tube and direction vectors
18723       xmin=boxxsize
18724       ymin=boxysize
18725 ! Find minimum distance in periodic box
18726         do j=-1,1
18727          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18728          vectube(1)=vectube(1)+boxxsize*j
18729          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18730          vectube(2)=vectube(2)+boxysize*j
18731          xminact=abs(vectube(1)-tubecenter(1))
18732          yminact=abs(vectube(2)-tubecenter(2))
18733            if (xmin.gt.xminact) then
18734             xmin=xminact
18735             xtemp=vectube(1)
18736            endif
18737            if (ymin.gt.yminact) then
18738              ymin=yminact
18739              ytemp=vectube(2)
18740             endif
18741          enddo
18742       vectube(1)=xtemp
18743       vectube(2)=ytemp
18744       vectube(1)=vectube(1)-tubecenter(1)
18745       vectube(2)=vectube(2)-tubecenter(2)
18746
18747 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18748 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18749
18750 !C as the tube is infinity we do not calculate the Z-vector use of Z
18751 !C as chosen axis
18752       vectube(3)=0.0d0
18753 !C now calculte the distance
18754        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18755 !C now normalize vector
18756       vectube(1)=vectube(1)/tub_r
18757       vectube(2)=vectube(2)/tub_r
18758 !C calculte rdiffrence between r and r0
18759       rdiff=tub_r-tubeR0
18760 !C and its 6 power
18761       rdiff6=rdiff**6.0d0
18762 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18763        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18764 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18765 !C       print *,rdiff,rdiff6,pep_aa_tube
18766 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18767 !C now we calculate gradient
18768        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18769             6.0d0*pep_bb_tube)/rdiff6/rdiff
18770 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18771 !C     &rdiff,fac
18772 !C now direction of gg_tube vector
18773         do j=1,3
18774         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18775         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18776         enddo
18777         enddo
18778 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18779 !C        print *,gg_tube(1,0),"TU"
18780
18781
18782        do i=itube_start,itube_end
18783 !C Lets not jump over memory as we use many times iti
18784          iti=itype(i,1)
18785 !C lets ommit dummy atoms for now
18786          if ((iti.eq.ntyp1)  &
18787 !C in UNRES uncomment the line below as GLY has no side-chain...
18788 !C      .or.(iti.eq.10)
18789         ) cycle
18790       xmin=boxxsize
18791       ymin=boxysize
18792         do j=-1,1
18793          vectube(1)=mod((c(1,i+nres)),boxxsize)
18794          vectube(1)=vectube(1)+boxxsize*j
18795          vectube(2)=mod((c(2,i+nres)),boxysize)
18796          vectube(2)=vectube(2)+boxysize*j
18797
18798          xminact=abs(vectube(1)-tubecenter(1))
18799          yminact=abs(vectube(2)-tubecenter(2))
18800            if (xmin.gt.xminact) then
18801             xmin=xminact
18802             xtemp=vectube(1)
18803            endif
18804            if (ymin.gt.yminact) then
18805              ymin=yminact
18806              ytemp=vectube(2)
18807             endif
18808          enddo
18809       vectube(1)=xtemp
18810       vectube(2)=ytemp
18811 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18812 !C     &     tubecenter(2)
18813       vectube(1)=vectube(1)-tubecenter(1)
18814       vectube(2)=vectube(2)-tubecenter(2)
18815
18816 !C as the tube is infinity we do not calculate the Z-vector use of Z
18817 !C as chosen axis
18818       vectube(3)=0.0d0
18819 !C now calculte the distance
18820        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18821 !C now normalize vector
18822       vectube(1)=vectube(1)/tub_r
18823       vectube(2)=vectube(2)/tub_r
18824
18825 !C calculte rdiffrence between r and r0
18826       rdiff=tub_r-tubeR0
18827 !C and its 6 power
18828       rdiff6=rdiff**6.0d0
18829 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18830        sc_aa_tube=sc_aa_tube_par(iti)
18831        sc_bb_tube=sc_bb_tube_par(iti)
18832        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18833        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18834              6.0d0*sc_bb_tube/rdiff6/rdiff
18835 !C now direction of gg_tube vector
18836          do j=1,3
18837           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18838           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18839          enddo
18840         enddo
18841         do i=itube_start,itube_end
18842           Etube=Etube+enetube(i)+enetube(i+nres)
18843         enddo
18844 !C        print *,"ETUBE", etube
18845         return
18846         end subroutine calctube
18847 !C TO DO 1) add to total energy
18848 !C       2) add to gradient summation
18849 !C       3) add reading parameters (AND of course oppening of PARAM file)
18850 !C       4) add reading the center of tube
18851 !C       5) add COMMONs
18852 !C       6) add to zerograd
18853 !C       7) allocate matrices
18854
18855
18856 !C-----------------------------------------------------------------------
18857 !C-----------------------------------------------------------
18858 !C This subroutine is to mimic the histone like structure but as well can be
18859 !C utilizet to nanostructures (infinit) small modification has to be used to
18860 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18861 !C gradient has to be modified at the ends
18862 !C The energy function is Kihara potential
18863 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18864 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18865 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18866 !C simple Kihara potential
18867       subroutine calctube2(Etube)
18868             real(kind=8),dimension(3) :: vectube
18869       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18870        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18871        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18872       integer:: i,j,iti
18873       Etube=0.0d0
18874       do i=itube_start,itube_end
18875         enetube(i)=0.0d0
18876         enetube(i+nres)=0.0d0
18877       enddo
18878 !C first we calculate the distance from tube center
18879 !C first sugare-phosphate group for NARES this would be peptide group
18880 !C for UNRES
18881        do i=itube_start,itube_end
18882 !C lets ommit dummy atoms for now
18883
18884        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18885 !C now calculate distance from center of tube and direction vectors
18886 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18887 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18888 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18889 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18890       xmin=boxxsize
18891       ymin=boxysize
18892         do j=-1,1
18893          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18894          vectube(1)=vectube(1)+boxxsize*j
18895          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18896          vectube(2)=vectube(2)+boxysize*j
18897
18898          xminact=abs(vectube(1)-tubecenter(1))
18899          yminact=abs(vectube(2)-tubecenter(2))
18900            if (xmin.gt.xminact) then
18901             xmin=xminact
18902             xtemp=vectube(1)
18903            endif
18904            if (ymin.gt.yminact) then
18905              ymin=yminact
18906              ytemp=vectube(2)
18907             endif
18908          enddo
18909       vectube(1)=xtemp
18910       vectube(2)=ytemp
18911       vectube(1)=vectube(1)-tubecenter(1)
18912       vectube(2)=vectube(2)-tubecenter(2)
18913
18914 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18915 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18916
18917 !C as the tube is infinity we do not calculate the Z-vector use of Z
18918 !C as chosen axis
18919       vectube(3)=0.0d0
18920 !C now calculte the distance
18921        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18922 !C now normalize vector
18923       vectube(1)=vectube(1)/tub_r
18924       vectube(2)=vectube(2)/tub_r
18925 !C calculte rdiffrence between r and r0
18926       rdiff=tub_r-tubeR0
18927 !C and its 6 power
18928       rdiff6=rdiff**6.0d0
18929 !C THIS FRAGMENT MAKES TUBE FINITE
18930         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18931         if (positi.le.0) positi=positi+boxzsize
18932 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18933 !c for each residue check if it is in lipid or lipid water border area
18934 !C       respos=mod(c(3,i+nres),boxzsize)
18935 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18936        if ((positi.gt.bordtubebot)  &
18937         .and.(positi.lt.bordtubetop)) then
18938 !C the energy transfer exist
18939         if (positi.lt.buftubebot) then
18940          fracinbuf=1.0d0-  &
18941            ((positi-bordtubebot)/tubebufthick)
18942 !C lipbufthick is thickenes of lipid buffore
18943          sstube=sscalelip(fracinbuf)
18944          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18945 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18946          enetube(i)=enetube(i)+sstube*tubetranenepep
18947 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18948 !C     &+ssgradtube*tubetranene(itype(i,1))
18949 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18950 !C     &+ssgradtube*tubetranene(itype(i,1))
18951 !C         print *,"doing sccale for lower part"
18952         elseif (positi.gt.buftubetop) then
18953          fracinbuf=1.0d0-  &
18954         ((bordtubetop-positi)/tubebufthick)
18955          sstube=sscalelip(fracinbuf)
18956          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18957          enetube(i)=enetube(i)+sstube*tubetranenepep
18958 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18959 !C     &+ssgradtube*tubetranene(itype(i,1))
18960 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18961 !C     &+ssgradtube*tubetranene(itype(i,1))
18962 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18963         else
18964          sstube=1.0d0
18965          ssgradtube=0.0d0
18966          enetube(i)=enetube(i)+sstube*tubetranenepep
18967 !C         print *,"I am in true lipid"
18968         endif
18969         else
18970 !C          sstube=0.0d0
18971 !C          ssgradtube=0.0d0
18972         cycle
18973         endif ! if in lipid or buffor
18974
18975 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18976        enetube(i)=enetube(i)+sstube* &
18977         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18978 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18979 !C       print *,rdiff,rdiff6,pep_aa_tube
18980 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18981 !C now we calculate gradient
18982        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18983              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18984 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18985 !C     &rdiff,fac
18986
18987 !C now direction of gg_tube vector
18988        do j=1,3
18989         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18990         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18991         enddo
18992          gg_tube(3,i)=gg_tube(3,i)  &
18993        +ssgradtube*enetube(i)/sstube/2.0d0
18994          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18995        +ssgradtube*enetube(i)/sstube/2.0d0
18996
18997         enddo
18998 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18999 !C        print *,gg_tube(1,0),"TU"
19000         do i=itube_start,itube_end
19001 !C Lets not jump over memory as we use many times iti
19002          iti=itype(i,1)
19003 !C lets ommit dummy atoms for now
19004          if ((iti.eq.ntyp1) &
19005 !!C in UNRES uncomment the line below as GLY has no side-chain...
19006            .or.(iti.eq.10) &
19007           ) cycle
19008           vectube(1)=c(1,i+nres)
19009           vectube(1)=mod(vectube(1),boxxsize)
19010           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19011           vectube(2)=c(2,i+nres)
19012           vectube(2)=mod(vectube(2),boxysize)
19013           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19014
19015       vectube(1)=vectube(1)-tubecenter(1)
19016       vectube(2)=vectube(2)-tubecenter(2)
19017 !C THIS FRAGMENT MAKES TUBE FINITE
19018         positi=(mod(c(3,i+nres),boxzsize))
19019         if (positi.le.0) positi=positi+boxzsize
19020 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19021 !c for each residue check if it is in lipid or lipid water border area
19022 !C       respos=mod(c(3,i+nres),boxzsize)
19023 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19024
19025        if ((positi.gt.bordtubebot)  &
19026         .and.(positi.lt.bordtubetop)) then
19027 !C the energy transfer exist
19028         if (positi.lt.buftubebot) then
19029          fracinbuf=1.0d0- &
19030             ((positi-bordtubebot)/tubebufthick)
19031 !C lipbufthick is thickenes of lipid buffore
19032          sstube=sscalelip(fracinbuf)
19033          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19034 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19035          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19036 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19037 !C     &+ssgradtube*tubetranene(itype(i,1))
19038 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19039 !C     &+ssgradtube*tubetranene(itype(i,1))
19040 !C         print *,"doing sccale for lower part"
19041         elseif (positi.gt.buftubetop) then
19042          fracinbuf=1.0d0- &
19043         ((bordtubetop-positi)/tubebufthick)
19044
19045          sstube=sscalelip(fracinbuf)
19046          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19047          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19048 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19049 !C     &+ssgradtube*tubetranene(itype(i,1))
19050 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19051 !C     &+ssgradtube*tubetranene(itype(i,1))
19052 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19053         else
19054          sstube=1.0d0
19055          ssgradtube=0.0d0
19056          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19057 !C         print *,"I am in true lipid"
19058         endif
19059         else
19060 !C          sstube=0.0d0
19061 !C          ssgradtube=0.0d0
19062         cycle
19063         endif ! if in lipid or buffor
19064 !CEND OF FINITE FRAGMENT
19065 !C as the tube is infinity we do not calculate the Z-vector use of Z
19066 !C as chosen axis
19067       vectube(3)=0.0d0
19068 !C now calculte the distance
19069        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19070 !C now normalize vector
19071       vectube(1)=vectube(1)/tub_r
19072       vectube(2)=vectube(2)/tub_r
19073 !C calculte rdiffrence between r and r0
19074       rdiff=tub_r-tubeR0
19075 !C and its 6 power
19076       rdiff6=rdiff**6.0d0
19077 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19078        sc_aa_tube=sc_aa_tube_par(iti)
19079        sc_bb_tube=sc_bb_tube_par(iti)
19080        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19081                        *sstube+enetube(i+nres)
19082 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19083 !C now we calculate gradient
19084        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19085             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19086 !C now direction of gg_tube vector
19087          do j=1,3
19088           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19089           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19090          enddo
19091          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19092        +ssgradtube*enetube(i+nres)/sstube
19093          gg_tube(3,i-1)= gg_tube(3,i-1) &
19094        +ssgradtube*enetube(i+nres)/sstube
19095
19096         enddo
19097         do i=itube_start,itube_end
19098           Etube=Etube+enetube(i)+enetube(i+nres)
19099         enddo
19100 !C        print *,"ETUBE", etube
19101         return
19102         end subroutine calctube2
19103 !=====================================================================================================================================
19104       subroutine calcnano(Etube)
19105       real(kind=8),dimension(3) :: vectube
19106
19107       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19108        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19109        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19110        integer:: i,j,iti,r
19111
19112       Etube=0.0d0
19113 !      print *,itube_start,itube_end,"poczatek"
19114       do i=itube_start,itube_end
19115         enetube(i)=0.0d0
19116         enetube(i+nres)=0.0d0
19117       enddo
19118 !C first we calculate the distance from tube center
19119 !C first sugare-phosphate group for NARES this would be peptide group
19120 !C for UNRES
19121        do i=itube_start,itube_end
19122 !C lets ommit dummy atoms for now
19123        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19124 !C now calculate distance from center of tube and direction vectors
19125       xmin=boxxsize
19126       ymin=boxysize
19127       zmin=boxzsize
19128
19129         do j=-1,1
19130          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19131          vectube(1)=vectube(1)+boxxsize*j
19132          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19133          vectube(2)=vectube(2)+boxysize*j
19134          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19135          vectube(3)=vectube(3)+boxzsize*j
19136
19137
19138          xminact=dabs(vectube(1)-tubecenter(1))
19139          yminact=dabs(vectube(2)-tubecenter(2))
19140          zminact=dabs(vectube(3)-tubecenter(3))
19141
19142            if (xmin.gt.xminact) then
19143             xmin=xminact
19144             xtemp=vectube(1)
19145            endif
19146            if (ymin.gt.yminact) then
19147              ymin=yminact
19148              ytemp=vectube(2)
19149             endif
19150            if (zmin.gt.zminact) then
19151              zmin=zminact
19152              ztemp=vectube(3)
19153             endif
19154          enddo
19155       vectube(1)=xtemp
19156       vectube(2)=ytemp
19157       vectube(3)=ztemp
19158
19159       vectube(1)=vectube(1)-tubecenter(1)
19160       vectube(2)=vectube(2)-tubecenter(2)
19161       vectube(3)=vectube(3)-tubecenter(3)
19162
19163 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19164 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19165 !C as the tube is infinity we do not calculate the Z-vector use of Z
19166 !C as chosen axis
19167 !C      vectube(3)=0.0d0
19168 !C now calculte the distance
19169        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19170 !C now normalize vector
19171       vectube(1)=vectube(1)/tub_r
19172       vectube(2)=vectube(2)/tub_r
19173       vectube(3)=vectube(3)/tub_r
19174 !C calculte rdiffrence between r and r0
19175       rdiff=tub_r-tubeR0
19176 !C and its 6 power
19177       rdiff6=rdiff**6.0d0
19178 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19179        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19180 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19181 !C       print *,rdiff,rdiff6,pep_aa_tube
19182 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19183 !C now we calculate gradient
19184        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19185             6.0d0*pep_bb_tube)/rdiff6/rdiff
19186 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19187 !C     &rdiff,fac
19188          if (acavtubpep.eq.0.0d0) then
19189 !C go to 667
19190          enecavtube(i)=0.0
19191          faccav=0.0
19192          else
19193          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19194          enecavtube(i)=  &
19195         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19196         /denominator
19197          enecavtube(i)=0.0
19198          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19199         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19200         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19201         /denominator**2.0d0
19202 !C         faccav=0.0
19203 !C         fac=fac+faccav
19204 !C 667     continue
19205          endif
19206           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19207         do j=1,3
19208         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19209         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19210         enddo
19211         enddo
19212
19213        do i=itube_start,itube_end
19214         enecavtube(i)=0.0d0
19215 !C Lets not jump over memory as we use many times iti
19216          iti=itype(i,1)
19217 !C lets ommit dummy atoms for now
19218          if ((iti.eq.ntyp1) &
19219 !C in UNRES uncomment the line below as GLY has no side-chain...
19220 !C      .or.(iti.eq.10)
19221          ) cycle
19222       xmin=boxxsize
19223       ymin=boxysize
19224       zmin=boxzsize
19225         do j=-1,1
19226          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19227          vectube(1)=vectube(1)+boxxsize*j
19228          vectube(2)=dmod((c(2,i+nres)),boxysize)
19229          vectube(2)=vectube(2)+boxysize*j
19230          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19231          vectube(3)=vectube(3)+boxzsize*j
19232
19233
19234          xminact=dabs(vectube(1)-tubecenter(1))
19235          yminact=dabs(vectube(2)-tubecenter(2))
19236          zminact=dabs(vectube(3)-tubecenter(3))
19237
19238            if (xmin.gt.xminact) then
19239             xmin=xminact
19240             xtemp=vectube(1)
19241            endif
19242            if (ymin.gt.yminact) then
19243              ymin=yminact
19244              ytemp=vectube(2)
19245             endif
19246            if (zmin.gt.zminact) then
19247              zmin=zminact
19248              ztemp=vectube(3)
19249             endif
19250          enddo
19251       vectube(1)=xtemp
19252       vectube(2)=ytemp
19253       vectube(3)=ztemp
19254
19255 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19256 !C     &     tubecenter(2)
19257       vectube(1)=vectube(1)-tubecenter(1)
19258       vectube(2)=vectube(2)-tubecenter(2)
19259       vectube(3)=vectube(3)-tubecenter(3)
19260 !C now calculte the distance
19261        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19262 !C now normalize vector
19263       vectube(1)=vectube(1)/tub_r
19264       vectube(2)=vectube(2)/tub_r
19265       vectube(3)=vectube(3)/tub_r
19266
19267 !C calculte rdiffrence between r and r0
19268       rdiff=tub_r-tubeR0
19269 !C and its 6 power
19270       rdiff6=rdiff**6.0d0
19271        sc_aa_tube=sc_aa_tube_par(iti)
19272        sc_bb_tube=sc_bb_tube_par(iti)
19273        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19274 !C       enetube(i+nres)=0.0d0
19275 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19276 !C now we calculate gradient
19277        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19278             6.0d0*sc_bb_tube/rdiff6/rdiff
19279 !C       fac=0.0
19280 !C now direction of gg_tube vector
19281 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19282          if (acavtub(iti).eq.0.0d0) then
19283 !C go to 667
19284          enecavtube(i+nres)=0.0d0
19285          faccav=0.0d0
19286          else
19287          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19288          enecavtube(i+nres)=   &
19289         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19290         /denominator
19291 !C         enecavtube(i)=0.0
19292          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19293         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19294         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19295         /denominator**2.0d0
19296 !C         faccav=0.0
19297          fac=fac+faccav
19298 !C 667     continue
19299          endif
19300 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19301 !C     &   enecavtube(i),faccav
19302 !C         print *,"licz=",
19303 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19304 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19305          do j=1,3
19306           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19307           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19308          enddo
19309           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19310         enddo
19311
19312
19313
19314         do i=itube_start,itube_end
19315           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19316          +enecavtube(i+nres)
19317         enddo
19318 !        do i=1,20
19319 !         print *,"begin", i,"a"
19320 !         do r=1,10000
19321 !          rdiff=r/100.0d0
19322 !          rdiff6=rdiff**6.0d0
19323 !          sc_aa_tube=sc_aa_tube_par(i)
19324 !          sc_bb_tube=sc_bb_tube_par(i)
19325 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19326 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19327 !          enecavtube(i)=   &
19328 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19329 !         /denominator
19330
19331 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19332 !         enddo
19333 !         print *,"end",i,"a"
19334 !        enddo
19335 !C        print *,"ETUBE", etube
19336         return
19337         end subroutine calcnano
19338
19339 !===============================================
19340 !--------------------------------------------------------------------------------
19341 !C first for shielding is setting of function of side-chains
19342
19343        subroutine set_shield_fac2
19344        real(kind=8) :: div77_81=0.974996043d0, &
19345         div4_81=0.2222222222d0
19346        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19347          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19348          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19349          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19350 !C the vector between center of side_chain and peptide group
19351        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19352          pept_group,costhet_grad,cosphi_grad_long, &
19353          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19354          sh_frac_dist_grad,pep_side
19355         integer i,j,k
19356 !C      write(2,*) "ivec",ivec_start,ivec_end
19357       do i=1,nres
19358         fac_shield(i)=0.0d0
19359         do j=1,3
19360         grad_shield(j,i)=0.0d0
19361         enddo
19362       enddo
19363       do i=ivec_start,ivec_end
19364 !C      do i=1,nres-1
19365 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19366       ishield_list(i)=0
19367       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19368 !Cif there two consequtive dummy atoms there is no peptide group between them
19369 !C the line below has to be changed for FGPROC>1
19370       VolumeTotal=0.0
19371       do k=1,nres
19372        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19373        dist_pep_side=0.0
19374        dist_side_calf=0.0
19375        do j=1,3
19376 !C first lets set vector conecting the ithe side-chain with kth side-chain
19377       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19378 !C      pep_side(j)=2.0d0
19379 !C and vector conecting the side-chain with its proper calfa
19380       side_calf(j)=c(j,k+nres)-c(j,k)
19381 !C      side_calf(j)=2.0d0
19382       pept_group(j)=c(j,i)-c(j,i+1)
19383 !C lets have their lenght
19384       dist_pep_side=pep_side(j)**2+dist_pep_side
19385       dist_side_calf=dist_side_calf+side_calf(j)**2
19386       dist_pept_group=dist_pept_group+pept_group(j)**2
19387       enddo
19388        dist_pep_side=sqrt(dist_pep_side)
19389        dist_pept_group=sqrt(dist_pept_group)
19390        dist_side_calf=sqrt(dist_side_calf)
19391       do j=1,3
19392         pep_side_norm(j)=pep_side(j)/dist_pep_side
19393         side_calf_norm(j)=dist_side_calf
19394       enddo
19395 !C now sscale fraction
19396        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19397 !C       print *,buff_shield,"buff"
19398 !C now sscale
19399         if (sh_frac_dist.le.0.0) cycle
19400 !C        print *,ishield_list(i),i
19401 !C If we reach here it means that this side chain reaches the shielding sphere
19402 !C Lets add him to the list for gradient
19403         ishield_list(i)=ishield_list(i)+1
19404 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19405 !C this list is essential otherwise problem would be O3
19406         shield_list(ishield_list(i),i)=k
19407 !C Lets have the sscale value
19408         if (sh_frac_dist.gt.1.0) then
19409          scale_fac_dist=1.0d0
19410          do j=1,3
19411          sh_frac_dist_grad(j)=0.0d0
19412          enddo
19413         else
19414          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19415                         *(2.0d0*sh_frac_dist-3.0d0)
19416          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19417                        /dist_pep_side/buff_shield*0.5d0
19418          do j=1,3
19419          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19420 !C         sh_frac_dist_grad(j)=0.0d0
19421 !C         scale_fac_dist=1.0d0
19422 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19423 !C     &                    sh_frac_dist_grad(j)
19424          enddo
19425         endif
19426 !C this is what is now we have the distance scaling now volume...
19427       short=short_r_sidechain(itype(k,1))
19428       long=long_r_sidechain(itype(k,1))
19429       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19430       sinthet=short/dist_pep_side*costhet
19431 !C now costhet_grad
19432 !C       costhet=0.6d0
19433 !C       sinthet=0.8
19434        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19435 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19436 !C     &             -short/dist_pep_side**2/costhet)
19437 !C       costhet_fac=0.0d0
19438        do j=1,3
19439          costhet_grad(j)=costhet_fac*pep_side(j)
19440        enddo
19441 !C remember for the final gradient multiply costhet_grad(j)
19442 !C for side_chain by factor -2 !
19443 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19444 !C pep_side0pept_group is vector multiplication
19445       pep_side0pept_group=0.0d0
19446       do j=1,3
19447       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19448       enddo
19449       cosalfa=(pep_side0pept_group/ &
19450       (dist_pep_side*dist_side_calf))
19451       fac_alfa_sin=1.0d0-cosalfa**2
19452       fac_alfa_sin=dsqrt(fac_alfa_sin)
19453       rkprim=fac_alfa_sin*(long-short)+short
19454 !C      rkprim=short
19455
19456 !C now costhet_grad
19457        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19458 !C       cosphi=0.6
19459        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19460        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19461            dist_pep_side**2)
19462 !C       sinphi=0.8
19463        do j=1,3
19464          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19465       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19466       *(long-short)/fac_alfa_sin*cosalfa/ &
19467       ((dist_pep_side*dist_side_calf))* &
19468       ((side_calf(j))-cosalfa* &
19469       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19470 !C       cosphi_grad_long(j)=0.0d0
19471         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19472       *(long-short)/fac_alfa_sin*cosalfa &
19473       /((dist_pep_side*dist_side_calf))* &
19474       (pep_side(j)- &
19475       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19476 !C       cosphi_grad_loc(j)=0.0d0
19477        enddo
19478 !C      print *,sinphi,sinthet
19479       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19480      &                    /VSolvSphere_div
19481 !C     &                    *wshield
19482 !C now the gradient...
19483       do j=1,3
19484       grad_shield(j,i)=grad_shield(j,i) &
19485 !C gradient po skalowaniu
19486                      +(sh_frac_dist_grad(j)*VofOverlap &
19487 !C  gradient po costhet
19488             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19489         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19490             sinphi/sinthet*costhet*costhet_grad(j) &
19491            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19492         )*wshield
19493 !C grad_shield_side is Cbeta sidechain gradient
19494       grad_shield_side(j,ishield_list(i),i)=&
19495              (sh_frac_dist_grad(j)*-2.0d0&
19496              *VofOverlap&
19497             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19498        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19499             sinphi/sinthet*costhet*costhet_grad(j)&
19500            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19501             )*wshield
19502
19503        grad_shield_loc(j,ishield_list(i),i)=   &
19504             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19505       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19506             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19507              ))&
19508              *wshield
19509       enddo
19510       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19511       enddo
19512       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19513
19514 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19515       enddo
19516       return
19517       end subroutine set_shield_fac2
19518 !----------------------------------------------------------------------------
19519 ! SOUBROUTINE FOR AFM
19520        subroutine AFMvel(Eafmforce)
19521        use MD_data, only:totTafm
19522       real(kind=8),dimension(3) :: diffafm
19523       real(kind=8) :: afmdist,Eafmforce
19524        integer :: i
19525 !C Only for check grad COMMENT if not used for checkgrad
19526 !C      totT=3.0d0
19527 !C--------------------------------------------------------
19528 !C      print *,"wchodze"
19529       afmdist=0.0d0
19530       Eafmforce=0.0d0
19531       do i=1,3
19532       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19533       afmdist=afmdist+diffafm(i)**2
19534       enddo
19535       afmdist=dsqrt(afmdist)
19536 !      totTafm=3.0
19537       Eafmforce=0.5d0*forceAFMconst &
19538       *(distafminit+totTafm*velAFMconst-afmdist)**2
19539 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19540       do i=1,3
19541       gradafm(i,afmend-1)=-forceAFMconst* &
19542        (distafminit+totTafm*velAFMconst-afmdist) &
19543        *diffafm(i)/afmdist
19544       gradafm(i,afmbeg-1)=forceAFMconst* &
19545       (distafminit+totTafm*velAFMconst-afmdist) &
19546       *diffafm(i)/afmdist
19547       enddo
19548 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19549       return
19550       end subroutine AFMvel
19551 !---------------------------------------------------------
19552        subroutine AFMforce(Eafmforce)
19553
19554       real(kind=8),dimension(3) :: diffafm
19555 !      real(kind=8) ::afmdist
19556       real(kind=8) :: afmdist,Eafmforce
19557       integer :: i
19558       afmdist=0.0d0
19559       Eafmforce=0.0d0
19560       do i=1,3
19561       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19562       afmdist=afmdist+diffafm(i)**2
19563       enddo
19564       afmdist=dsqrt(afmdist)
19565 !      print *,afmdist,distafminit
19566       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19567       do i=1,3
19568       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19569       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19570       enddo
19571 !C      print *,'AFM',Eafmforce
19572       return
19573       end subroutine AFMforce
19574
19575 !-----------------------------------------------------------------------------
19576 #ifdef WHAM
19577       subroutine read_ssHist
19578 !      implicit none
19579 !      Includes
19580 !      include 'DIMENSIONS'
19581 !      include "DIMENSIONS.FREE"
19582 !      include 'COMMON.FREE'
19583 !     Local variables
19584       integer :: i,j
19585       character(len=80) :: controlcard
19586
19587       do i=1,dyn_nssHist
19588         call card_concat(controlcard,.true.)
19589         read(controlcard,*) &
19590              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19591       enddo
19592
19593       return
19594       end subroutine read_ssHist
19595 #endif
19596 !-----------------------------------------------------------------------------
19597       integer function indmat(i,j)
19598 !el
19599 ! get the position of the jth ijth fragment of the chain coordinate system
19600 ! in the fromto array.
19601         integer :: i,j
19602
19603         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19604       return
19605       end function indmat
19606 !-----------------------------------------------------------------------------
19607       real(kind=8) function sigm(x)
19608 !el
19609        real(kind=8) :: x
19610         sigm=0.25d0*x
19611       return
19612       end function sigm
19613 !-----------------------------------------------------------------------------
19614 !-----------------------------------------------------------------------------
19615       subroutine alloc_ener_arrays
19616 !EL Allocation of arrays used by module energy
19617       use MD_data, only: mset
19618 !el local variables
19619       integer :: i,j
19620
19621       if(nres.lt.100) then
19622         maxconts=nres
19623       elseif(nres.lt.200) then
19624         maxconts=0.8*nres      ! Max. number of contacts per residue
19625       else
19626         maxconts=0.6*nres ! (maxconts=maxres/4)
19627       endif
19628       maxcont=12*nres      ! Max. number of SC contacts
19629       maxvar=6*nres      ! Max. number of variables
19630 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19631       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19632 !----------------------
19633 ! arrays in subroutine init_int_table
19634 !el#ifdef MPI
19635 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19636 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19637 !el#endif
19638       allocate(nint_gr(nres))
19639       allocate(nscp_gr(nres))
19640       allocate(ielstart(nres))
19641       allocate(ielend(nres))
19642 !(maxres)
19643       allocate(istart(nres,maxint_gr))
19644       allocate(iend(nres,maxint_gr))
19645 !(maxres,maxint_gr)
19646       allocate(iscpstart(nres,maxint_gr))
19647       allocate(iscpend(nres,maxint_gr))
19648 !(maxres,maxint_gr)
19649       allocate(ielstart_vdw(nres))
19650       allocate(ielend_vdw(nres))
19651 !(maxres)
19652       allocate(nint_gr_nucl(nres))
19653       allocate(nscp_gr_nucl(nres))
19654       allocate(ielstart_nucl(nres))
19655       allocate(ielend_nucl(nres))
19656 !(maxres)
19657       allocate(istart_nucl(nres,maxint_gr))
19658       allocate(iend_nucl(nres,maxint_gr))
19659 !(maxres,maxint_gr)
19660       allocate(iscpstart_nucl(nres,maxint_gr))
19661       allocate(iscpend_nucl(nres,maxint_gr))
19662 !(maxres,maxint_gr)
19663       allocate(ielstart_vdw_nucl(nres))
19664       allocate(ielend_vdw_nucl(nres))
19665
19666       allocate(lentyp(0:nfgtasks-1))
19667 !(0:maxprocs-1)
19668 !----------------------
19669 ! commom.contacts
19670 !      common /contacts/
19671       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19672       allocate(icont(2,maxcont))
19673 !(2,maxcont)
19674 !      common /contacts1/
19675       allocate(num_cont(0:nres+4))
19676 !(maxres)
19677       allocate(jcont(maxconts,nres))
19678 !(maxconts,maxres)
19679       allocate(facont(maxconts,nres))
19680 !(maxconts,maxres)
19681       allocate(gacont(3,maxconts,nres))
19682 !(3,maxconts,maxres)
19683 !      common /contacts_hb/
19684       allocate(gacontp_hb1(3,maxconts,nres))
19685       allocate(gacontp_hb2(3,maxconts,nres))
19686       allocate(gacontp_hb3(3,maxconts,nres))
19687       allocate(gacontm_hb1(3,maxconts,nres))
19688       allocate(gacontm_hb2(3,maxconts,nres))
19689       allocate(gacontm_hb3(3,maxconts,nres))
19690       allocate(gacont_hbr(3,maxconts,nres))
19691       allocate(grij_hb_cont(3,maxconts,nres))
19692 !(3,maxconts,maxres)
19693       allocate(facont_hb(maxconts,nres))
19694
19695       allocate(ees0p(maxconts,nres))
19696       allocate(ees0m(maxconts,nres))
19697       allocate(d_cont(maxconts,nres))
19698       allocate(ees0plist(maxconts,nres))
19699
19700 !(maxconts,maxres)
19701       allocate(num_cont_hb(nres))
19702 !(maxres)
19703       allocate(jcont_hb(maxconts,nres))
19704 !(maxconts,maxres)
19705 !      common /rotat/
19706       allocate(Ug(2,2,nres))
19707       allocate(Ugder(2,2,nres))
19708       allocate(Ug2(2,2,nres))
19709       allocate(Ug2der(2,2,nres))
19710 !(2,2,maxres)
19711       allocate(obrot(2,nres))
19712       allocate(obrot2(2,nres))
19713       allocate(obrot_der(2,nres))
19714       allocate(obrot2_der(2,nres))
19715 !(2,maxres)
19716 !      common /precomp1/
19717       allocate(mu(2,nres))
19718       allocate(muder(2,nres))
19719       allocate(Ub2(2,nres))
19720       Ub2(1,:)=0.0d0
19721       Ub2(2,:)=0.0d0
19722       allocate(Ub2der(2,nres))
19723       allocate(Ctobr(2,nres))
19724       allocate(Ctobrder(2,nres))
19725       allocate(Dtobr2(2,nres))
19726       allocate(Dtobr2der(2,nres))
19727 !(2,maxres)
19728       allocate(EUg(2,2,nres))
19729       allocate(EUgder(2,2,nres))
19730       allocate(CUg(2,2,nres))
19731       allocate(CUgder(2,2,nres))
19732       allocate(DUg(2,2,nres))
19733       allocate(Dugder(2,2,nres))
19734       allocate(DtUg2(2,2,nres))
19735       allocate(DtUg2der(2,2,nres))
19736 !(2,2,maxres)
19737 !      common /precomp2/
19738       allocate(Ug2Db1t(2,nres))
19739       allocate(Ug2Db1tder(2,nres))
19740       allocate(CUgb2(2,nres))
19741       allocate(CUgb2der(2,nres))
19742 !(2,maxres)
19743       allocate(EUgC(2,2,nres))
19744       allocate(EUgCder(2,2,nres))
19745       allocate(EUgD(2,2,nres))
19746       allocate(EUgDder(2,2,nres))
19747       allocate(DtUg2EUg(2,2,nres))
19748       allocate(Ug2DtEUg(2,2,nres))
19749 !(2,2,maxres)
19750       allocate(Ug2DtEUgder(2,2,2,nres))
19751       allocate(DtUg2EUgder(2,2,2,nres))
19752 !(2,2,2,maxres)
19753 !      common /rotat_old/
19754       allocate(costab(nres))
19755       allocate(sintab(nres))
19756       allocate(costab2(nres))
19757       allocate(sintab2(nres))
19758 !(maxres)
19759 !      common /dipmat/
19760       allocate(a_chuj(2,2,maxconts,nres))
19761 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19762       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19763 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19764 !      common /contdistrib/
19765       allocate(ncont_sent(nres))
19766       allocate(ncont_recv(nres))
19767
19768       allocate(iat_sent(nres))
19769 !(maxres)
19770       allocate(iint_sent(4,nres,nres))
19771       allocate(iint_sent_local(4,nres,nres))
19772 !(4,maxres,maxres)
19773       allocate(iturn3_sent(4,0:nres+4))
19774       allocate(iturn4_sent(4,0:nres+4))
19775       allocate(iturn3_sent_local(4,nres))
19776       allocate(iturn4_sent_local(4,nres))
19777 !(4,maxres)
19778       allocate(itask_cont_from(0:nfgtasks-1))
19779       allocate(itask_cont_to(0:nfgtasks-1))
19780 !(0:max_fg_procs-1)
19781
19782
19783
19784 !----------------------
19785 ! commom.deriv;
19786 !      common /derivat/
19787       allocate(dcdv(6,maxdim))
19788       allocate(dxdv(6,maxdim))
19789 !(6,maxdim)
19790       allocate(dxds(6,nres))
19791 !(6,maxres)
19792       allocate(gradx(3,-1:nres,0:2))
19793       allocate(gradc(3,-1:nres,0:2))
19794 !(3,maxres,2)
19795       allocate(gvdwx(3,-1:nres))
19796       allocate(gvdwc(3,-1:nres))
19797       allocate(gelc(3,-1:nres))
19798       allocate(gelc_long(3,-1:nres))
19799       allocate(gvdwpp(3,-1:nres))
19800       allocate(gvdwc_scpp(3,-1:nres))
19801       allocate(gradx_scp(3,-1:nres))
19802       allocate(gvdwc_scp(3,-1:nres))
19803       allocate(ghpbx(3,-1:nres))
19804       allocate(ghpbc(3,-1:nres))
19805       allocate(gradcorr(3,-1:nres))
19806       allocate(gradcorr_long(3,-1:nres))
19807       allocate(gradcorr5_long(3,-1:nres))
19808       allocate(gradcorr6_long(3,-1:nres))
19809       allocate(gcorr6_turn_long(3,-1:nres))
19810       allocate(gradxorr(3,-1:nres))
19811       allocate(gradcorr5(3,-1:nres))
19812       allocate(gradcorr6(3,-1:nres))
19813       allocate(gliptran(3,-1:nres))
19814       allocate(gliptranc(3,-1:nres))
19815       allocate(gliptranx(3,-1:nres))
19816       allocate(gshieldx(3,-1:nres))
19817       allocate(gshieldc(3,-1:nres))
19818       allocate(gshieldc_loc(3,-1:nres))
19819       allocate(gshieldx_ec(3,-1:nres))
19820       allocate(gshieldc_ec(3,-1:nres))
19821       allocate(gshieldc_loc_ec(3,-1:nres))
19822       allocate(gshieldx_t3(3,-1:nres))
19823       allocate(gshieldc_t3(3,-1:nres))
19824       allocate(gshieldc_loc_t3(3,-1:nres))
19825       allocate(gshieldx_t4(3,-1:nres))
19826       allocate(gshieldc_t4(3,-1:nres))
19827       allocate(gshieldc_loc_t4(3,-1:nres))
19828       allocate(gshieldx_ll(3,-1:nres))
19829       allocate(gshieldc_ll(3,-1:nres))
19830       allocate(gshieldc_loc_ll(3,-1:nres))
19831       allocate(grad_shield(3,-1:nres))
19832       allocate(gg_tube_sc(3,-1:nres))
19833       allocate(gg_tube(3,-1:nres))
19834       allocate(gradafm(3,-1:nres))
19835       allocate(gradb_nucl(3,-1:nres))
19836       allocate(gradbx_nucl(3,-1:nres))
19837       allocate(gvdwpsb1(3,-1:nres))
19838       allocate(gelpp(3,-1:nres))
19839       allocate(gvdwpsb(3,-1:nres))
19840       allocate(gelsbc(3,-1:nres))
19841       allocate(gelsbx(3,-1:nres))
19842       allocate(gvdwsbx(3,-1:nres))
19843       allocate(gvdwsbc(3,-1:nres))
19844       allocate(gsbloc(3,-1:nres))
19845       allocate(gsblocx(3,-1:nres))
19846       allocate(gradcorr_nucl(3,-1:nres))
19847       allocate(gradxorr_nucl(3,-1:nres))
19848       allocate(gradcorr3_nucl(3,-1:nres))
19849       allocate(gradxorr3_nucl(3,-1:nres))
19850       allocate(gvdwpp_nucl(3,-1:nres))
19851       allocate(gradpepcat(3,-1:nres))
19852       allocate(gradpepcatx(3,-1:nres))
19853       allocate(gradcatcat(3,-1:nres))
19854 !(3,maxres)
19855       allocate(grad_shield_side(3,50,nres))
19856       allocate(grad_shield_loc(3,50,nres))
19857 ! grad for shielding surroing
19858       allocate(gloc(0:maxvar,0:2))
19859       allocate(gloc_x(0:maxvar,2))
19860 !(maxvar,2)
19861       allocate(gel_loc(3,-1:nres))
19862       allocate(gel_loc_long(3,-1:nres))
19863       allocate(gcorr3_turn(3,-1:nres))
19864       allocate(gcorr4_turn(3,-1:nres))
19865       allocate(gcorr6_turn(3,-1:nres))
19866       allocate(gradb(3,-1:nres))
19867       allocate(gradbx(3,-1:nres))
19868 !(3,maxres)
19869       allocate(gel_loc_loc(maxvar))
19870       allocate(gel_loc_turn3(maxvar))
19871       allocate(gel_loc_turn4(maxvar))
19872       allocate(gel_loc_turn6(maxvar))
19873       allocate(gcorr_loc(maxvar))
19874       allocate(g_corr5_loc(maxvar))
19875       allocate(g_corr6_loc(maxvar))
19876 !(maxvar)
19877       allocate(gsccorc(3,-1:nres))
19878       allocate(gsccorx(3,-1:nres))
19879 !(3,maxres)
19880       allocate(gsccor_loc(-1:nres))
19881 !(maxres)
19882       allocate(gvdwx_scbase(3,-1:nres))
19883       allocate(gvdwc_scbase(3,-1:nres))
19884       allocate(gvdwx_pepbase(3,-1:nres))
19885       allocate(gvdwc_pepbase(3,-1:nres))
19886       allocate(gvdwx_scpho(3,-1:nres))
19887       allocate(gvdwc_scpho(3,-1:nres))
19888       allocate(gvdwc_peppho(3,-1:nres))
19889
19890       allocate(dtheta(3,2,-1:nres))
19891 !(3,2,maxres)
19892       allocate(gscloc(3,-1:nres))
19893       allocate(gsclocx(3,-1:nres))
19894 !(3,maxres)
19895       allocate(dphi(3,3,-1:nres))
19896       allocate(dalpha(3,3,-1:nres))
19897       allocate(domega(3,3,-1:nres))
19898 !(3,3,maxres)
19899 !      common /deriv_scloc/
19900       allocate(dXX_C1tab(3,nres))
19901       allocate(dYY_C1tab(3,nres))
19902       allocate(dZZ_C1tab(3,nres))
19903       allocate(dXX_Ctab(3,nres))
19904       allocate(dYY_Ctab(3,nres))
19905       allocate(dZZ_Ctab(3,nres))
19906       allocate(dXX_XYZtab(3,nres))
19907       allocate(dYY_XYZtab(3,nres))
19908       allocate(dZZ_XYZtab(3,nres))
19909 !(3,maxres)
19910 !      common /mpgrad/
19911       allocate(jgrad_start(nres))
19912       allocate(jgrad_end(nres))
19913 !(maxres)
19914 !----------------------
19915
19916 !      common /indices/
19917       allocate(ibond_displ(0:nfgtasks-1))
19918       allocate(ibond_count(0:nfgtasks-1))
19919       allocate(ithet_displ(0:nfgtasks-1))
19920       allocate(ithet_count(0:nfgtasks-1))
19921       allocate(iphi_displ(0:nfgtasks-1))
19922       allocate(iphi_count(0:nfgtasks-1))
19923       allocate(iphi1_displ(0:nfgtasks-1))
19924       allocate(iphi1_count(0:nfgtasks-1))
19925       allocate(ivec_displ(0:nfgtasks-1))
19926       allocate(ivec_count(0:nfgtasks-1))
19927       allocate(iset_displ(0:nfgtasks-1))
19928       allocate(iset_count(0:nfgtasks-1))
19929       allocate(iint_count(0:nfgtasks-1))
19930       allocate(iint_displ(0:nfgtasks-1))
19931 !(0:max_fg_procs-1)
19932 !----------------------
19933 ! common.MD
19934 !      common /mdgrad/
19935       allocate(gcart(3,-1:nres))
19936       allocate(gxcart(3,-1:nres))
19937 !(3,0:MAXRES)
19938       allocate(gradcag(3,-1:nres))
19939       allocate(gradxag(3,-1:nres))
19940 !(3,MAXRES)
19941 !      common /back_constr/
19942 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19943       allocate(dutheta(nres))
19944       allocate(dugamma(nres))
19945 !(maxres)
19946       allocate(duscdiff(3,nres))
19947       allocate(duscdiffx(3,nres))
19948 !(3,maxres)
19949 !el i io:read_fragments
19950 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19951 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19952 !      common /qmeas/
19953 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19954 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19955       allocate(mset(0:nprocs))  !(maxprocs/20)
19956       mset(:)=0
19957 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19958 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19959       allocate(dUdconst(3,0:nres))
19960       allocate(dUdxconst(3,0:nres))
19961       allocate(dqwol(3,0:nres))
19962       allocate(dxqwol(3,0:nres))
19963 !(3,0:MAXRES)
19964 !----------------------
19965 ! common.sbridge
19966 !      common /sbridge/ in io_common: read_bridge
19967 !el    allocate((:),allocatable :: iss      !(maxss)
19968 !      common /links/  in io_common: read_bridge
19969 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19970 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19971 !      common /dyn_ssbond/
19972 ! and side-chain vectors in theta or phi.
19973       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19974 !(maxres,maxres)
19975 !      do i=1,nres
19976 !        do j=i+1,nres
19977       dyn_ssbond_ij(:,:)=1.0d300
19978 !        enddo
19979 !      enddo
19980
19981 !      if (nss.gt.0) then
19982         allocate(idssb(maxdim),jdssb(maxdim))
19983 !        allocate(newihpb(nss),newjhpb(nss))
19984 !(maxdim)
19985 !      endif
19986       allocate(ishield_list(nres))
19987       allocate(shield_list(50,nres))
19988       allocate(dyn_ss_mask(nres))
19989       allocate(fac_shield(nres))
19990       allocate(enetube(nres*2))
19991       allocate(enecavtube(nres*2))
19992
19993 !(maxres)
19994       dyn_ss_mask(:)=.false.
19995 !----------------------
19996 ! common.sccor
19997 ! Parameters of the SCCOR term
19998 !      common/sccor/
19999 !el in io_conf: parmread
20000 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20001 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20002 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20003 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20004 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20005 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20006 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20007 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20008 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20009 !----------------
20010       allocate(gloc_sc(3,0:2*nres,0:10))
20011 !(3,0:maxres2,10)maxres2=2*maxres
20012       allocate(dcostau(3,3,3,2*nres))
20013       allocate(dsintau(3,3,3,2*nres))
20014       allocate(dtauangle(3,3,3,2*nres))
20015       allocate(dcosomicron(3,3,3,2*nres))
20016       allocate(domicron(3,3,3,2*nres))
20017 !(3,3,3,maxres2)maxres2=2*maxres
20018 !----------------------
20019 ! common.var
20020 !      common /restr/
20021       allocate(varall(maxvar))
20022 !(maxvar)(maxvar=6*maxres)
20023       allocate(mask_theta(nres))
20024       allocate(mask_phi(nres))
20025       allocate(mask_side(nres))
20026 !(maxres)
20027 !----------------------
20028 ! common.vectors
20029 !      common /vectors/
20030       allocate(uy(3,nres))
20031       allocate(uz(3,nres))
20032 !(3,maxres)
20033       allocate(uygrad(3,3,2,nres))
20034       allocate(uzgrad(3,3,2,nres))
20035 !(3,3,2,maxres)
20036
20037       return
20038       end subroutine alloc_ener_arrays
20039 !-----------------------------------------------------------------
20040       subroutine ebond_nucl(estr_nucl)
20041 !c
20042 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20043 !c
20044
20045       real(kind=8),dimension(3) :: u,ud
20046       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20047       real(kind=8) :: estr_nucl,diff
20048       integer :: iti,i,j,k,nbi
20049       estr_nucl=0.0d0
20050 !C      print *,"I enter ebond"
20051       if (energy_dec) &
20052       write (iout,*) "ibondp_start,ibondp_end",&
20053        ibondp_nucl_start,ibondp_nucl_end
20054       do i=ibondp_nucl_start,ibondp_nucl_end
20055         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20056          itype(i,2).eq.ntyp1_molec(2)) cycle
20057 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20058 !          do j=1,3
20059 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20060 !     &      *dc(j,i-1)/vbld(i)
20061 !          enddo
20062 !          if (energy_dec) write(iout,*)
20063 !     &       "estr1",i,vbld(i),distchainmax,
20064 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20065
20066           diff = vbld(i)-vbldp0_nucl
20067           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20068           vbldp0_nucl,diff,AKP_nucl*diff*diff
20069           estr_nucl=estr_nucl+diff*diff
20070 !          print *,estr_nucl
20071           do j=1,3
20072             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20073           enddo
20074 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20075       enddo
20076       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20077 !      print *,"partial sum", estr_nucl,AKP_nucl
20078
20079       if (energy_dec) &
20080       write (iout,*) "ibondp_start,ibondp_end",&
20081        ibond_nucl_start,ibond_nucl_end
20082
20083       do i=ibond_nucl_start,ibond_nucl_end
20084 !C        print *, "I am stuck",i
20085         iti=itype(i,2)
20086         if (iti.eq.ntyp1_molec(2)) cycle
20087           nbi=nbondterm_nucl(iti)
20088 !C        print *,iti,nbi
20089           if (nbi.eq.1) then
20090             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20091
20092             if (energy_dec) &
20093            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20094            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20095             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20096 !            print *,estr_nucl
20097             do j=1,3
20098               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20099             enddo
20100           else
20101             do j=1,nbi
20102               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20103               ud(j)=aksc_nucl(j,iti)*diff
20104               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20105             enddo
20106             uprod=u(1)
20107             do j=2,nbi
20108               uprod=uprod*u(j)
20109             enddo
20110             usum=0.0d0
20111             usumsqder=0.0d0
20112             do j=1,nbi
20113               uprod1=1.0d0
20114               uprod2=1.0d0
20115               do k=1,nbi
20116                 if (k.ne.j) then
20117                   uprod1=uprod1*u(k)
20118                   uprod2=uprod2*u(k)*u(k)
20119                 endif
20120               enddo
20121               usum=usum+uprod1
20122               usumsqder=usumsqder+ud(j)*uprod2
20123             enddo
20124             estr_nucl=estr_nucl+uprod/usum
20125             do j=1,3
20126              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20127             enddo
20128         endif
20129       enddo
20130 !C      print *,"I am about to leave ebond"
20131       return
20132       end subroutine ebond_nucl
20133
20134 !-----------------------------------------------------------------------------
20135       subroutine ebend_nucl(etheta_nucl)
20136       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20137       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20138       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20139       logical :: lprn=.false., lprn1=.false.
20140 !el local variables
20141       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20142       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20143       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20144 ! local variables for constrains
20145       real(kind=8) :: difi,thetiii
20146        integer itheta
20147       etheta_nucl=0.0D0
20148 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20149       do i=ithet_nucl_start,ithet_nucl_end
20150         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20151         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20152         (itype(i,2).eq.ntyp1_molec(2))) cycle
20153         dethetai=0.0d0
20154         dephii=0.0d0
20155         dephii1=0.0d0
20156         theti2=0.5d0*theta(i)
20157         ityp2=ithetyp_nucl(itype(i-1,2))
20158         do k=1,nntheterm_nucl
20159           coskt(k)=dcos(k*theti2)
20160           sinkt(k)=dsin(k*theti2)
20161         enddo
20162         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20163 #ifdef OSF
20164           phii=phi(i)
20165           if (phii.ne.phii) phii=150.0
20166 #else
20167           phii=phi(i)
20168 #endif
20169           ityp1=ithetyp_nucl(itype(i-2,2))
20170           do k=1,nsingle_nucl
20171             cosph1(k)=dcos(k*phii)
20172             sinph1(k)=dsin(k*phii)
20173           enddo
20174         else
20175           phii=0.0d0
20176           ityp1=nthetyp_nucl+1
20177           do k=1,nsingle_nucl
20178             cosph1(k)=0.0d0
20179             sinph1(k)=0.0d0
20180           enddo
20181         endif
20182
20183         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20184 #ifdef OSF
20185           phii1=phi(i+1)
20186           if (phii1.ne.phii1) phii1=150.0
20187           phii1=pinorm(phii1)
20188 #else
20189           phii1=phi(i+1)
20190 #endif
20191           ityp3=ithetyp_nucl(itype(i,2))
20192           do k=1,nsingle_nucl
20193             cosph2(k)=dcos(k*phii1)
20194             sinph2(k)=dsin(k*phii1)
20195           enddo
20196         else
20197           phii1=0.0d0
20198           ityp3=nthetyp_nucl+1
20199           do k=1,nsingle_nucl
20200             cosph2(k)=0.0d0
20201             sinph2(k)=0.0d0
20202           enddo
20203         endif
20204         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20205         do k=1,ndouble_nucl
20206           do l=1,k-1
20207             ccl=cosph1(l)*cosph2(k-l)
20208             ssl=sinph1(l)*sinph2(k-l)
20209             scl=sinph1(l)*cosph2(k-l)
20210             csl=cosph1(l)*sinph2(k-l)
20211             cosph1ph2(l,k)=ccl-ssl
20212             cosph1ph2(k,l)=ccl+ssl
20213             sinph1ph2(l,k)=scl+csl
20214             sinph1ph2(k,l)=scl-csl
20215           enddo
20216         enddo
20217         if (lprn) then
20218         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20219          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20220         write (iout,*) "coskt and sinkt",nntheterm_nucl
20221         do k=1,nntheterm_nucl
20222           write (iout,*) k,coskt(k),sinkt(k)
20223         enddo
20224         endif
20225         do k=1,ntheterm_nucl
20226           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20227           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20228            *coskt(k)
20229           if (lprn)&
20230          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20231           " ethetai",ethetai
20232         enddo
20233         if (lprn) then
20234         write (iout,*) "cosph and sinph"
20235         do k=1,nsingle_nucl
20236           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20237         enddo
20238         write (iout,*) "cosph1ph2 and sinph2ph2"
20239         do k=2,ndouble_nucl
20240           do l=1,k-1
20241             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20242               sinph1ph2(l,k),sinph1ph2(k,l)
20243           enddo
20244         enddo
20245         write(iout,*) "ethetai",ethetai
20246         endif
20247         do m=1,ntheterm2_nucl
20248           do k=1,nsingle_nucl
20249             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20250               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20251               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20252               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20253             ethetai=ethetai+sinkt(m)*aux
20254             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20255             dephii=dephii+k*sinkt(m)*(&
20256                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20257                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20258             dephii1=dephii1+k*sinkt(m)*(&
20259                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20260                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20261             if (lprn) &
20262            write (iout,*) "m",m," k",k," bbthet",&
20263               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20264               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20265               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20266               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20267           enddo
20268         enddo
20269         if (lprn) &
20270         write(iout,*) "ethetai",ethetai
20271         do m=1,ntheterm3_nucl
20272           do k=2,ndouble_nucl
20273             do l=1,k-1
20274               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20275                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20276                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20277                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20278               ethetai=ethetai+sinkt(m)*aux
20279               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20280               dephii=dephii+l*sinkt(m)*(&
20281                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20282                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20283                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20284                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20285               dephii1=dephii1+(k-l)*sinkt(m)*( &
20286                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20287                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20288                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20289                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20290               if (lprn) then
20291               write (iout,*) "m",m," k",k," l",l," ffthet", &
20292                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20293                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20294                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20295                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20296               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20297                  cosph1ph2(k,l)*sinkt(m),&
20298                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20299               endif
20300             enddo
20301           enddo
20302         enddo
20303 10      continue
20304         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20305         i,theta(i)*rad2deg,phii*rad2deg, &
20306         phii1*rad2deg,ethetai
20307         etheta_nucl=etheta_nucl+ethetai
20308 !        print *,i,"partial sum",etheta_nucl
20309         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20310         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20311         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20312       enddo
20313       return
20314       end subroutine ebend_nucl
20315 !----------------------------------------------------
20316       subroutine etor_nucl(etors_nucl)
20317 !      implicit real*8 (a-h,o-z)
20318 !      include 'DIMENSIONS'
20319 !      include 'COMMON.VAR'
20320 !      include 'COMMON.GEO'
20321 !      include 'COMMON.LOCAL'
20322 !      include 'COMMON.TORSION'
20323 !      include 'COMMON.INTERACT'
20324 !      include 'COMMON.DERIV'
20325 !      include 'COMMON.CHAIN'
20326 !      include 'COMMON.NAMES'
20327 !      include 'COMMON.IOUNITS'
20328 !      include 'COMMON.FFIELD'
20329 !      include 'COMMON.TORCNSTR'
20330 !      include 'COMMON.CONTROL'
20331       real(kind=8) :: etors_nucl,edihcnstr
20332       logical :: lprn
20333 !el local variables
20334       integer :: i,j,iblock,itori,itori1
20335       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20336                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20337 ! Set lprn=.true. for debugging
20338       lprn=.false.
20339 !     lprn=.true.
20340       etors_nucl=0.0D0
20341 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20342       do i=iphi_nucl_start,iphi_nucl_end
20343         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20344              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20345              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20346         etors_ii=0.0D0
20347         itori=itortyp_nucl(itype(i-2,2))
20348         itori1=itortyp_nucl(itype(i-1,2))
20349         phii=phi(i)
20350 !         print *,i,itori,itori1
20351         gloci=0.0D0
20352 !C Regular cosine and sine terms
20353         do j=1,nterm_nucl(itori,itori1)
20354           v1ij=v1_nucl(j,itori,itori1)
20355           v2ij=v2_nucl(j,itori,itori1)
20356           cosphi=dcos(j*phii)
20357           sinphi=dsin(j*phii)
20358           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20359           if (energy_dec) etors_ii=etors_ii+&
20360                      v1ij*cosphi+v2ij*sinphi
20361           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20362         enddo
20363 !C Lorentz terms
20364 !C                         v1
20365 !C  E = SUM ----------------------------------- - v1
20366 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20367 !C
20368         cosphi=dcos(0.5d0*phii)
20369         sinphi=dsin(0.5d0*phii)
20370         do j=1,nlor_nucl(itori,itori1)
20371           vl1ij=vlor1_nucl(j,itori,itori1)
20372           vl2ij=vlor2_nucl(j,itori,itori1)
20373           vl3ij=vlor3_nucl(j,itori,itori1)
20374           pom=vl2ij*cosphi+vl3ij*sinphi
20375           pom1=1.0d0/(pom*pom+1.0d0)
20376           etors_nucl=etors_nucl+vl1ij*pom1
20377           if (energy_dec) etors_ii=etors_ii+ &
20378                      vl1ij*pom1
20379           pom=-pom*pom1*pom1
20380           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20381         enddo
20382 !C Subtract the constant term
20383         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20384           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20385               'etor',i,etors_ii-v0_nucl(itori,itori1)
20386         if (lprn) &
20387        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20388        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20389        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20390         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20391 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20392       enddo
20393       return
20394       end subroutine etor_nucl
20395 !------------------------------------------------------------
20396       subroutine epp_nucl_sub(evdw1,ees)
20397 !C
20398 !C This subroutine calculates the average interaction energy and its gradient
20399 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20400 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20401 !C The potential depends both on the distance of peptide-group centers and on
20402 !C the orientation of the CA-CA virtual bonds.
20403 !C
20404       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20405       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20406       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20407                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20408                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20409       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20410                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20411       integer xshift,yshift,zshift
20412       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20413       real(kind=8) :: ees,eesij
20414 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20415       real(kind=8) scal_el /0.5d0/
20416       t_eelecij=0.0d0
20417       ees=0.0D0
20418       evdw1=0.0D0
20419       ind=0
20420 !c
20421 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20422 !c
20423 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20424       do i=iatel_s_nucl,iatel_e_nucl
20425         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20426         dxi=dc(1,i)
20427         dyi=dc(2,i)
20428         dzi=dc(3,i)
20429         dx_normi=dc_norm(1,i)
20430         dy_normi=dc_norm(2,i)
20431         dz_normi=dc_norm(3,i)
20432         xmedi=c(1,i)+0.5d0*dxi
20433         ymedi=c(2,i)+0.5d0*dyi
20434         zmedi=c(3,i)+0.5d0*dzi
20435           xmedi=dmod(xmedi,boxxsize)
20436           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20437           ymedi=dmod(ymedi,boxysize)
20438           if (ymedi.lt.0) ymedi=ymedi+boxysize
20439           zmedi=dmod(zmedi,boxzsize)
20440           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20441
20442         do j=ielstart_nucl(i),ielend_nucl(i)
20443           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20444           ind=ind+1
20445           dxj=dc(1,j)
20446           dyj=dc(2,j)
20447           dzj=dc(3,j)
20448 !          xj=c(1,j)+0.5D0*dxj-xmedi
20449 !          yj=c(2,j)+0.5D0*dyj-ymedi
20450 !          zj=c(3,j)+0.5D0*dzj-zmedi
20451           xj=c(1,j)+0.5D0*dxj
20452           yj=c(2,j)+0.5D0*dyj
20453           zj=c(3,j)+0.5D0*dzj
20454           xj=mod(xj,boxxsize)
20455           if (xj.lt.0) xj=xj+boxxsize
20456           yj=mod(yj,boxysize)
20457           if (yj.lt.0) yj=yj+boxysize
20458           zj=mod(zj,boxzsize)
20459           if (zj.lt.0) zj=zj+boxzsize
20460       isubchap=0
20461       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20462       xj_safe=xj
20463       yj_safe=yj
20464       zj_safe=zj
20465       do xshift=-1,1
20466       do yshift=-1,1
20467       do zshift=-1,1
20468           xj=xj_safe+xshift*boxxsize
20469           yj=yj_safe+yshift*boxysize
20470           zj=zj_safe+zshift*boxzsize
20471           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20472           if(dist_temp.lt.dist_init) then
20473             dist_init=dist_temp
20474             xj_temp=xj
20475             yj_temp=yj
20476             zj_temp=zj
20477             isubchap=1
20478           endif
20479        enddo
20480        enddo
20481        enddo
20482        if (isubchap.eq.1) then
20483 !C          print *,i,j
20484           xj=xj_temp-xmedi
20485           yj=yj_temp-ymedi
20486           zj=zj_temp-zmedi
20487        else
20488           xj=xj_safe-xmedi
20489           yj=yj_safe-ymedi
20490           zj=zj_safe-zmedi
20491        endif
20492
20493           rij=xj*xj+yj*yj+zj*zj
20494 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20495           fac=(r0pp**2/rij)**3
20496           ev1=epspp*fac*fac
20497           ev2=epspp*fac
20498           evdw1ij=ev1-2*ev2
20499           fac=(-ev1-evdw1ij)/rij
20500 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20501           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20502           evdw1=evdw1+evdw1ij
20503 !C
20504 !C Calculate contributions to the Cartesian gradient.
20505 !C
20506           ggg(1)=fac*xj
20507           ggg(2)=fac*yj
20508           ggg(3)=fac*zj
20509           do k=1,3
20510             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20511             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20512           enddo
20513 !c phoshate-phosphate electrostatic interactions
20514           rij=dsqrt(rij)
20515           fac=1.0d0/rij
20516           eesij=dexp(-BEES*rij)*fac
20517 !          write (2,*)"fac",fac," eesijpp",eesij
20518           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20519           ees=ees+eesij
20520 !c          fac=-eesij*fac
20521           fac=-(fac+BEES)*eesij*fac
20522           ggg(1)=fac*xj
20523           ggg(2)=fac*yj
20524           ggg(3)=fac*zj
20525 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20526 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20527 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20528           do k=1,3
20529             gelpp(k,i)=gelpp(k,i)-ggg(k)
20530             gelpp(k,j)=gelpp(k,j)+ggg(k)
20531           enddo
20532         enddo ! j
20533       enddo   ! i
20534 !c      ees=332.0d0*ees
20535       ees=AEES*ees
20536       do i=nnt,nct
20537 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20538         do k=1,3
20539           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20540 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20541           gelpp(k,i)=AEES*gelpp(k,i)
20542         enddo
20543 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20544       enddo
20545 !c      write (2,*) "total EES",ees
20546       return
20547       end subroutine epp_nucl_sub
20548 !---------------------------------------------------------------------
20549       subroutine epsb(evdwpsb,eelpsb)
20550 !      use comm_locel
20551 !C
20552 !C This subroutine calculates the excluded-volume interaction energy between
20553 !C peptide-group centers and side chains and its gradient in virtual-bond and
20554 !C side-chain vectors.
20555 !C
20556       real(kind=8),dimension(3):: ggg
20557       integer :: i,iint,j,k,iteli,itypj,subchap
20558       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20559                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20560       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20561                     dist_temp, dist_init
20562       integer xshift,yshift,zshift
20563
20564 !cd    print '(a)','Enter ESCP'
20565 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20566       eelpsb=0.0d0
20567       evdwpsb=0.0d0
20568 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20569       do i=iatscp_s_nucl,iatscp_e_nucl
20570         if (itype(i,2).eq.ntyp1_molec(2) &
20571          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20572         xi=0.5D0*(c(1,i)+c(1,i+1))
20573         yi=0.5D0*(c(2,i)+c(2,i+1))
20574         zi=0.5D0*(c(3,i)+c(3,i+1))
20575           xi=mod(xi,boxxsize)
20576           if (xi.lt.0) xi=xi+boxxsize
20577           yi=mod(yi,boxysize)
20578           if (yi.lt.0) yi=yi+boxysize
20579           zi=mod(zi,boxzsize)
20580           if (zi.lt.0) zi=zi+boxzsize
20581
20582         do iint=1,nscp_gr_nucl(i)
20583
20584         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20585           itypj=itype(j,2)
20586           if (itypj.eq.ntyp1_molec(2)) cycle
20587 !C Uncomment following three lines for SC-p interactions
20588 !c         xj=c(1,nres+j)-xi
20589 !c         yj=c(2,nres+j)-yi
20590 !c         zj=c(3,nres+j)-zi
20591 !C Uncomment following three lines for Ca-p interactions
20592 !          xj=c(1,j)-xi
20593 !          yj=c(2,j)-yi
20594 !          zj=c(3,j)-zi
20595           xj=c(1,j)
20596           yj=c(2,j)
20597           zj=c(3,j)
20598           xj=mod(xj,boxxsize)
20599           if (xj.lt.0) xj=xj+boxxsize
20600           yj=mod(yj,boxysize)
20601           if (yj.lt.0) yj=yj+boxysize
20602           zj=mod(zj,boxzsize)
20603           if (zj.lt.0) zj=zj+boxzsize
20604       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20605       xj_safe=xj
20606       yj_safe=yj
20607       zj_safe=zj
20608       subchap=0
20609       do xshift=-1,1
20610       do yshift=-1,1
20611       do zshift=-1,1
20612           xj=xj_safe+xshift*boxxsize
20613           yj=yj_safe+yshift*boxysize
20614           zj=zj_safe+zshift*boxzsize
20615           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20616           if(dist_temp.lt.dist_init) then
20617             dist_init=dist_temp
20618             xj_temp=xj
20619             yj_temp=yj
20620             zj_temp=zj
20621             subchap=1
20622           endif
20623        enddo
20624        enddo
20625        enddo
20626        if (subchap.eq.1) then
20627           xj=xj_temp-xi
20628           yj=yj_temp-yi
20629           zj=zj_temp-zi
20630        else
20631           xj=xj_safe-xi
20632           yj=yj_safe-yi
20633           zj=zj_safe-zi
20634        endif
20635
20636           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20637           fac=rrij**expon2
20638           e1=fac*fac*aad_nucl(itypj)
20639           e2=fac*bad_nucl(itypj)
20640           if (iabs(j-i) .le. 2) then
20641             e1=scal14*e1
20642             e2=scal14*e2
20643           endif
20644           evdwij=e1+e2
20645           evdwpsb=evdwpsb+evdwij
20646           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20647              'evdw2',i,j,evdwij,"tu4"
20648 !C
20649 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20650 !C
20651           fac=-(evdwij+e1)*rrij
20652           ggg(1)=xj*fac
20653           ggg(2)=yj*fac
20654           ggg(3)=zj*fac
20655           do k=1,3
20656             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20657             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20658           enddo
20659         enddo
20660
20661         enddo ! iint
20662       enddo ! i
20663       do i=1,nct
20664         do j=1,3
20665           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20666           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20667         enddo
20668       enddo
20669       return
20670       end subroutine epsb
20671
20672 !------------------------------------------------------
20673       subroutine esb_gb(evdwsb,eelsb)
20674       use comm_locel
20675       use calc_data_nucl
20676       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20677       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20678       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20679       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20680                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20681       integer :: ii
20682       logical lprn
20683       evdw=0.0D0
20684       eelsb=0.0d0
20685       ecorr=0.0d0
20686       evdwsb=0.0D0
20687       lprn=.false.
20688       ind=0
20689 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20690       do i=iatsc_s_nucl,iatsc_e_nucl
20691         num_conti=0
20692         num_conti2=0
20693         itypi=itype(i,2)
20694 !        PRINT *,"I=",i,itypi
20695         if (itypi.eq.ntyp1_molec(2)) cycle
20696         itypi1=itype(i+1,2)
20697         xi=c(1,nres+i)
20698         yi=c(2,nres+i)
20699         zi=c(3,nres+i)
20700           xi=dmod(xi,boxxsize)
20701           if (xi.lt.0) xi=xi+boxxsize
20702           yi=dmod(yi,boxysize)
20703           if (yi.lt.0) yi=yi+boxysize
20704           zi=dmod(zi,boxzsize)
20705           if (zi.lt.0) zi=zi+boxzsize
20706
20707         dxi=dc_norm(1,nres+i)
20708         dyi=dc_norm(2,nres+i)
20709         dzi=dc_norm(3,nres+i)
20710         dsci_inv=vbld_inv(i+nres)
20711 !C
20712 !C Calculate SC interaction energy.
20713 !C
20714         do iint=1,nint_gr_nucl(i)
20715 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20716           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20717             ind=ind+1
20718 !            print *,"JESTEM"
20719             itypj=itype(j,2)
20720             if (itypj.eq.ntyp1_molec(2)) cycle
20721             dscj_inv=vbld_inv(j+nres)
20722             sig0ij=sigma_nucl(itypi,itypj)
20723             chi1=chi_nucl(itypi,itypj)
20724             chi2=chi_nucl(itypj,itypi)
20725             chi12=chi1*chi2
20726             chip1=chip_nucl(itypi,itypj)
20727             chip2=chip_nucl(itypj,itypi)
20728             chip12=chip1*chip2
20729 !            xj=c(1,nres+j)-xi
20730 !            yj=c(2,nres+j)-yi
20731 !            zj=c(3,nres+j)-zi
20732            xj=c(1,nres+j)
20733            yj=c(2,nres+j)
20734            zj=c(3,nres+j)
20735           xj=dmod(xj,boxxsize)
20736           if (xj.lt.0) xj=xj+boxxsize
20737           yj=dmod(yj,boxysize)
20738           if (yj.lt.0) yj=yj+boxysize
20739           zj=dmod(zj,boxzsize)
20740           if (zj.lt.0) zj=zj+boxzsize
20741       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20742       xj_safe=xj
20743       yj_safe=yj
20744       zj_safe=zj
20745       subchap=0
20746       do xshift=-1,1
20747       do yshift=-1,1
20748       do zshift=-1,1
20749           xj=xj_safe+xshift*boxxsize
20750           yj=yj_safe+yshift*boxysize
20751           zj=zj_safe+zshift*boxzsize
20752           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20753           if(dist_temp.lt.dist_init) then
20754             dist_init=dist_temp
20755             xj_temp=xj
20756             yj_temp=yj
20757             zj_temp=zj
20758             subchap=1
20759           endif
20760        enddo
20761        enddo
20762        enddo
20763        if (subchap.eq.1) then
20764           xj=xj_temp-xi
20765           yj=yj_temp-yi
20766           zj=zj_temp-zi
20767        else
20768           xj=xj_safe-xi
20769           yj=yj_safe-yi
20770           zj=zj_safe-zi
20771        endif
20772
20773             dxj=dc_norm(1,nres+j)
20774             dyj=dc_norm(2,nres+j)
20775             dzj=dc_norm(3,nres+j)
20776             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20777             rij=dsqrt(rrij)
20778 !C Calculate angle-dependent terms of energy and contributions to their
20779 !C derivatives.
20780             erij(1)=xj*rij
20781             erij(2)=yj*rij
20782             erij(3)=zj*rij
20783             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20784             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20785             om12=dxi*dxj+dyi*dyj+dzi*dzj
20786             call sc_angular_nucl
20787             sigsq=1.0D0/sigsq
20788             sig=sig0ij*dsqrt(sigsq)
20789             rij_shift=1.0D0/rij-sig+sig0ij
20790 !            print *,rij_shift,"rij_shift"
20791 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20792 !c     &       " rij_shift",rij_shift
20793             if (rij_shift.le.0.0D0) then
20794               evdw=1.0D20
20795               return
20796             endif
20797             sigder=-sig*sigsq
20798 !c---------------------------------------------------------------
20799             rij_shift=1.0D0/rij_shift
20800             fac=rij_shift**expon
20801             e1=fac*fac*aa_nucl(itypi,itypj)
20802             e2=fac*bb_nucl(itypi,itypj)
20803             evdwij=eps1*eps2rt*(e1+e2)
20804 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20805 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20806             eps2der=evdwij
20807             evdwij=evdwij*eps2rt
20808             evdwsb=evdwsb+evdwij
20809             if (lprn) then
20810             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
20811             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
20812             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20813              restyp(itypi,2),i,restyp(itypj,2),j, &
20814              epsi,sigm,chi1,chi2,chip1,chip2, &
20815              eps1,eps2rt**2,sig,sig0ij, &
20816              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20817             evdwij
20818             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20819             endif
20820
20821             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20822                              'evdw',i,j,evdwij,"tu3"
20823
20824
20825 !C Calculate gradient components.
20826             e1=e1*eps1*eps2rt**2
20827             fac=-expon*(e1+evdwij)*rij_shift
20828             sigder=fac*sigder
20829             fac=rij*fac
20830 !c            fac=0.0d0
20831 !C Calculate the radial part of the gradient
20832             gg(1)=xj*fac
20833             gg(2)=yj*fac
20834             gg(3)=zj*fac
20835 !C Calculate angular part of the gradient.
20836             call sc_grad_nucl
20837             call eelsbij(eelij,num_conti2)
20838             if (energy_dec .and. &
20839            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20840           write (istat,'(e14.5)') evdwij
20841             eelsb=eelsb+eelij
20842           enddo      ! j
20843         enddo        ! iint
20844         num_cont_hb(i)=num_conti2
20845       enddo          ! i
20846 !c      write (iout,*) "Number of loop steps in EGB:",ind
20847 !cccc      energy_dec=.false.
20848       return
20849       end subroutine esb_gb
20850 !-------------------------------------------------------------------------------
20851       subroutine eelsbij(eesij,num_conti2)
20852       use comm_locel
20853       use calc_data_nucl
20854       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20855       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20856       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20857                     dist_temp, dist_init,rlocshield,fracinbuf
20858       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20859
20860 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20861       real(kind=8) scal_el /0.5d0/
20862       integer :: iteli,itelj,kkk,kkll,m,isubchap
20863       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20864       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20865       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20866                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20867                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20868                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20869                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20870                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20871                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20872                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20873       ind=ind+1
20874       itypi=itype(i,2)
20875       itypj=itype(j,2)
20876 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20877       ael6i=ael6_nucl(itypi,itypj)
20878       ael3i=ael3_nucl(itypi,itypj)
20879       ael63i=ael63_nucl(itypi,itypj)
20880       ael32i=ael32_nucl(itypi,itypj)
20881 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20882 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20883       dxj=dc(1,j+nres)
20884       dyj=dc(2,j+nres)
20885       dzj=dc(3,j+nres)
20886       dx_normi=dc_norm(1,i+nres)
20887       dy_normi=dc_norm(2,i+nres)
20888       dz_normi=dc_norm(3,i+nres)
20889       dx_normj=dc_norm(1,j+nres)
20890       dy_normj=dc_norm(2,j+nres)
20891       dz_normj=dc_norm(3,j+nres)
20892 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20893 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20894 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20895       if (ipot_nucl.ne.2) then
20896         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20897         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20898         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20899       else
20900         cosa=om12
20901         cosb=om1
20902         cosg=om2
20903       endif
20904       r3ij=rij*rrij
20905       r6ij=r3ij*r3ij
20906       fac=cosa-3.0D0*cosb*cosg
20907       facfac=fac*fac
20908       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20909       fac3=ael6i*r6ij
20910       fac4=ael3i*r3ij
20911       fac5=ael63i*r6ij
20912       fac6=ael32i*r6ij
20913 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20914 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20915       el1=fac3*(4.0D0+facfac-fac1)
20916       el2=fac4*fac
20917       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20918       el4=fac6*facfac
20919       eesij=el1+el2+el3+el4
20920 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20921       ees0ij=4.0D0+facfac-fac1
20922
20923       if (energy_dec) then
20924           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20925           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20926            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20927            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20928            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20929           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20930       endif
20931
20932 !C
20933 !C Calculate contributions to the Cartesian gradient.
20934 !C
20935       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20936       fac1=fac
20937 !c      erij(1)=xj*rmij
20938 !c      erij(2)=yj*rmij
20939 !c      erij(3)=zj*rmij
20940 !*
20941 !* Radial derivatives. First process both termini of the fragment (i,j)
20942 !*
20943       ggg(1)=facel*xj
20944       ggg(2)=facel*yj
20945       ggg(3)=facel*zj
20946       do k=1,3
20947         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20948         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20949         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20950         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20951       enddo
20952 !*
20953 !* Angular part
20954 !*
20955       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20956       fac4=-3.0D0*fac4
20957       fac3=-6.0D0*fac3
20958       fac5= 6.0d0*fac5
20959       fac6=-6.0d0*fac6
20960       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20961        fac6*fac1*cosg
20962       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20963        fac6*fac1*cosb
20964       do k=1,3
20965         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20966         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20967       enddo
20968       do k=1,3
20969         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20970       enddo
20971       do k=1,3
20972         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20973              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20974              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20975         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20976              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20977              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20978         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20979         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20980       enddo
20981 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
20982        IF ( j.gt.i+1 .and.&
20983           num_conti.le.maxconts) THEN
20984 !C
20985 !C Calculate the contact function. The ith column of the array JCONT will
20986 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20987 !C greater than I). The arrays FACONT and GACONT will contain the values of
20988 !C the contact function and its derivative.
20989         r0ij=2.20D0*sigma(itypi,itypj)
20990 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20991         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20992 !c        write (2,*) "fcont",fcont
20993         if (fcont.gt.0.0D0) then
20994           num_conti=num_conti+1
20995           num_conti2=num_conti2+1
20996
20997           if (num_conti.gt.maxconts) then
20998             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20999                           ' will skip next contacts for this conf.'
21000           else
21001             jcont_hb(num_conti,i)=j
21002 !c            write (iout,*) "num_conti",num_conti,
21003 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21004 !C Calculate contact energies
21005             cosa4=4.0D0*cosa
21006             wij=cosa-3.0D0*cosb*cosg
21007             cosbg1=cosb+cosg
21008             cosbg2=cosb-cosg
21009             fac3=dsqrt(-ael6i)*r3ij
21010 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21011             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21012             if (ees0tmp.gt.0) then
21013               ees0pij=dsqrt(ees0tmp)
21014             else
21015               ees0pij=0
21016             endif
21017             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21018             if (ees0tmp.gt.0) then
21019               ees0mij=dsqrt(ees0tmp)
21020             else
21021               ees0mij=0
21022             endif
21023             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21024             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21025 !c            write (iout,*) "i",i," j",j,
21026 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21027             ees0pij1=fac3/ees0pij
21028             ees0mij1=fac3/ees0mij
21029             fac3p=-3.0D0*fac3*rrij
21030             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21031             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21032             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21033             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21034             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21035             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21036             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21037             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21038             ecosap=ecosa1+ecosa2
21039             ecosbp=ecosb1+ecosb2
21040             ecosgp=ecosg1+ecosg2
21041             ecosam=ecosa1-ecosa2
21042             ecosbm=ecosb1-ecosb2
21043             ecosgm=ecosg1-ecosg2
21044 !C End diagnostics
21045             facont_hb(num_conti,i)=fcont
21046             fprimcont=fprimcont/rij
21047             do k=1,3
21048               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21049               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21050             enddo
21051             gggp(1)=gggp(1)+ees0pijp*xj
21052             gggp(2)=gggp(2)+ees0pijp*yj
21053             gggp(3)=gggp(3)+ees0pijp*zj
21054             gggm(1)=gggm(1)+ees0mijp*xj
21055             gggm(2)=gggm(2)+ees0mijp*yj
21056             gggm(3)=gggm(3)+ees0mijp*zj
21057 !C Derivatives due to the contact function
21058             gacont_hbr(1,num_conti,i)=fprimcont*xj
21059             gacont_hbr(2,num_conti,i)=fprimcont*yj
21060             gacont_hbr(3,num_conti,i)=fprimcont*zj
21061             do k=1,3
21062 !c
21063 !c Gradient of the correlation terms
21064 !c
21065               gacontp_hb1(k,num_conti,i)= &
21066              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21067             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21068               gacontp_hb2(k,num_conti,i)= &
21069              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21070             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21071               gacontp_hb3(k,num_conti,i)=gggp(k)
21072               gacontm_hb1(k,num_conti,i)= &
21073              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21074             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21075               gacontm_hb2(k,num_conti,i)= &
21076              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21077             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21078               gacontm_hb3(k,num_conti,i)=gggm(k)
21079             enddo
21080           endif
21081         endif
21082       ENDIF
21083       return
21084       end subroutine eelsbij
21085 !------------------------------------------------------------------
21086       subroutine sc_grad_nucl
21087       use comm_locel
21088       use calc_data_nucl
21089       real(kind=8),dimension(3) :: dcosom1,dcosom2
21090       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21091       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21092       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21093       do k=1,3
21094         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21095         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21096       enddo
21097       do k=1,3
21098         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21099       enddo
21100       do k=1,3
21101         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21102                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21103                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21104         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21105                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21106                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21107       enddo
21108 !C
21109 !C Calculate the components of the gradient in DC and X
21110 !C
21111       do l=1,3
21112         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21113         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21114       enddo
21115       return
21116       end subroutine sc_grad_nucl
21117 !-----------------------------------------------------------------------
21118       subroutine esb(esbloc)
21119 !C Calculate the local energy of a side chain and its derivatives in the
21120 !C corresponding virtual-bond valence angles THETA and the spherical angles
21121 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21122 !C added by Urszula Kozlowska. 07/11/2007
21123 !C
21124       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21125       real(kind=8),dimension(9):: x
21126      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21127       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21128       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21129       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21130        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21131        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21132        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21133        integer::it,nlobit,i,j,k
21134 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21135       delta=0.02d0*pi
21136       esbloc=0.0D0
21137       do i=loc_start_nucl,loc_end_nucl
21138         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21139         costtab(i+1) =dcos(theta(i+1))
21140         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21141         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21142         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21143         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21144         cosfac=dsqrt(cosfac2)
21145         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21146         sinfac=dsqrt(sinfac2)
21147         it=itype(i,2)
21148         if (it.eq.10) goto 1
21149
21150 !c
21151 !C  Compute the axes of tghe local cartesian coordinates system; store in
21152 !c   x_prime, y_prime and z_prime
21153 !c
21154         do j=1,3
21155           x_prime(j) = 0.00
21156           y_prime(j) = 0.00
21157           z_prime(j) = 0.00
21158         enddo
21159 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21160 !C     &   dc_norm(3,i+nres)
21161         do j = 1,3
21162           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21163           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21164         enddo
21165         do j = 1,3
21166           z_prime(j) = -uz(j,i-1)
21167 !           z_prime(j)=0.0
21168         enddo
21169
21170         xx=0.0d0
21171         yy=0.0d0
21172         zz=0.0d0
21173         do j = 1,3
21174           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21175           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21176           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21177         enddo
21178
21179         xxtab(i)=xx
21180         yytab(i)=yy
21181         zztab(i)=zz
21182          it=itype(i,2)
21183         do j = 1,9
21184           x(j) = sc_parmin_nucl(j,it)
21185         enddo
21186 #ifdef CHECK_COORD
21187 !Cc diagnostics - remove later
21188         xx1 = dcos(alph(2))
21189         yy1 = dsin(alph(2))*dcos(omeg(2))
21190         zz1 = -dsin(alph(2))*dsin(omeg(2))
21191         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21192          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21193          xx1,yy1,zz1
21194 !C,"  --- ", xx_w,yy_w,zz_w
21195 !c end diagnostics
21196 #endif
21197         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21198         esbloc = esbloc + sumene
21199         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21200 !        print *,"enecomp",sumene,sumene2
21201 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21202 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21203 #ifdef DEBUG
21204         write (2,*) "x",(x(k),k=1,9)
21205 !C
21206 !C This section to check the numerical derivatives of the energy of ith side
21207 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21208 !C #define DEBUG in the code to turn it on.
21209 !C
21210         write (2,*) "sumene               =",sumene
21211         aincr=1.0d-7
21212         xxsave=xx
21213         xx=xx+aincr
21214         write (2,*) xx,yy,zz
21215         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21216         de_dxx_num=(sumenep-sumene)/aincr
21217         xx=xxsave
21218         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21219         yysave=yy
21220         yy=yy+aincr
21221         write (2,*) xx,yy,zz
21222         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21223         de_dyy_num=(sumenep-sumene)/aincr
21224         yy=yysave
21225         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21226         zzsave=zz
21227         zz=zz+aincr
21228         write (2,*) xx,yy,zz
21229         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21230         de_dzz_num=(sumenep-sumene)/aincr
21231         zz=zzsave
21232         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21233         costsave=cost2tab(i+1)
21234         sintsave=sint2tab(i+1)
21235         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21236         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21237         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21238         de_dt_num=(sumenep-sumene)/aincr
21239         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21240         cost2tab(i+1)=costsave
21241         sint2tab(i+1)=sintsave
21242 !C End of diagnostics section.
21243 #endif
21244 !C
21245 !C Compute the gradient of esc
21246 !C
21247         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21248         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21249         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21250         de_dtt=0.0d0
21251 #ifdef DEBUG
21252         write (2,*) "x",(x(k),k=1,9)
21253         write (2,*) "xx",xx," yy",yy," zz",zz
21254         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21255           " de_zz   ",de_zz," de_tt   ",de_tt
21256         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21257           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21258 #endif
21259 !C
21260        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21261        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21262        cosfac2xx=cosfac2*xx
21263        sinfac2yy=sinfac2*yy
21264        do k = 1,3
21265          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21266            vbld_inv(i+1)
21267          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21268            vbld_inv(i)
21269          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21270          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21271 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21272 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21273 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21274 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21275          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21276          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21277          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21278          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21279          dZZ_Ci1(k)=0.0d0
21280          dZZ_Ci(k)=0.0d0
21281          do j=1,3
21282            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21283            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21284          enddo
21285
21286          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21287          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21288          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21289 !c
21290          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21291          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21292        enddo
21293
21294        do k=1,3
21295          dXX_Ctab(k,i)=dXX_Ci(k)
21296          dXX_C1tab(k,i)=dXX_Ci1(k)
21297          dYY_Ctab(k,i)=dYY_Ci(k)
21298          dYY_C1tab(k,i)=dYY_Ci1(k)
21299          dZZ_Ctab(k,i)=dZZ_Ci(k)
21300          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21301          dXX_XYZtab(k,i)=dXX_XYZ(k)
21302          dYY_XYZtab(k,i)=dYY_XYZ(k)
21303          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21304        enddo
21305        do k = 1,3
21306 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21307 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21308 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21309 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21310 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21311 !c     &    dt_dci(k)
21312 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21313 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21314          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21315          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21316          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21317          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21318          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21319          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21320 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21321        enddo
21322 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21323 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21324
21325 !C to check gradient call subroutine check_grad
21326
21327     1 continue
21328       enddo
21329       return
21330       end subroutine esb
21331 !=-------------------------------------------------------
21332       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21333 !      implicit none
21334       real(kind=8),dimension(9):: x(9)
21335        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21336       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21337       integer i
21338 !c      write (2,*) "enesc"
21339 !c      write (2,*) "x",(x(i),i=1,9)
21340 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21341       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21342         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21343         + x(9)*yy*zz
21344       enesc_nucl=sumene
21345       return
21346       end function enesc_nucl
21347 !-----------------------------------------------------------------------------
21348       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21349 #ifdef MPI
21350       include 'mpif.h'
21351       integer,parameter :: max_cont=2000
21352       integer,parameter:: max_dim=2*(8*3+6)
21353       integer, parameter :: msglen1=max_cont*max_dim
21354       integer,parameter :: msglen2=2*msglen1
21355       integer source,CorrelType,CorrelID,Error
21356       real(kind=8) :: buffer(max_cont,max_dim)
21357       integer status(MPI_STATUS_SIZE)
21358       integer :: ierror,nbytes
21359 #endif
21360       real(kind=8),dimension(3):: gx(3),gx1(3)
21361       real(kind=8) :: time00
21362       logical lprn,ldone
21363       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21364       real(kind=8) ecorr,ecorr3
21365       integer :: n_corr,n_corr1,mm,msglen
21366 !C Set lprn=.true. for debugging
21367       lprn=.false.
21368       n_corr=0
21369       n_corr1=0
21370 #ifdef MPI
21371       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21372
21373       if (nfgtasks.le.1) goto 30
21374       if (lprn) then
21375         write (iout,'(a)') 'Contact function values:'
21376         do i=nnt,nct-1
21377           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21378          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21379          j=1,num_cont_hb(i))
21380         enddo
21381       endif
21382 !C Caution! Following code assumes that electrostatic interactions concerning
21383 !C a given atom are split among at most two processors!
21384       CorrelType=477
21385       CorrelID=fg_rank+1
21386       ldone=.false.
21387       do i=1,max_cont
21388         do j=1,max_dim
21389           buffer(i,j)=0.0D0
21390         enddo
21391       enddo
21392       mm=mod(fg_rank,2)
21393 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21394       if (mm) 20,20,10
21395    10 continue
21396 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21397       if (fg_rank.gt.0) then
21398 !C Send correlation contributions to the preceding processor
21399         msglen=msglen1
21400         nn=num_cont_hb(iatel_s_nucl)
21401         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21402 !c        write (*,*) 'The BUFFER array:'
21403 !c        do i=1,nn
21404 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21405 !c        enddo
21406         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21407           msglen=msglen2
21408           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21409 !C Clear the contacts of the atom passed to the neighboring processor
21410         nn=num_cont_hb(iatel_s_nucl+1)
21411 !c        do i=1,nn
21412 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21413 !c        enddo
21414             num_cont_hb(iatel_s_nucl)=0
21415         endif
21416 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21417 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21418 !cd   & ' msglen=',msglen
21419 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21420 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21421 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21422         time00=MPI_Wtime()
21423         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21424          CorrelType,FG_COMM,IERROR)
21425         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21426 !cd      write (iout,*) 'Processor ',fg_rank,
21427 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21428 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21429 !c        write (*,*) 'Processor ',fg_rank,
21430 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21431 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21432 !c        msglen=msglen1
21433       endif ! (fg_rank.gt.0)
21434       if (ldone) goto 30
21435       ldone=.true.
21436    20 continue
21437 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21438       if (fg_rank.lt.nfgtasks-1) then
21439 !C Receive correlation contributions from the next processor
21440         msglen=msglen1
21441         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21442 !cd      write (iout,*) 'Processor',fg_rank,
21443 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21444 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21445 !c        write (*,*) 'Processor',fg_rank,
21446 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21447 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21448         time00=MPI_Wtime()
21449         nbytes=-1
21450         do while (nbytes.le.0)
21451           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21452           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21453         enddo
21454 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21455         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21456          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21457         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21458 !c        write (*,*) 'Processor',fg_rank,
21459 !c     &' has received correlation contribution from processor',fg_rank+1,
21460 !c     & ' msglen=',msglen,' nbytes=',nbytes
21461 !c        write (*,*) 'The received BUFFER array:'
21462 !c        do i=1,max_cont
21463 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21464 !c        enddo
21465         if (msglen.eq.msglen1) then
21466           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21467         else if (msglen.eq.msglen2)  then
21468           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21469           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21470         else
21471           write (iout,*) &
21472       'ERROR!!!! message length changed while processing correlations.'
21473           write (*,*) &
21474       'ERROR!!!! message length changed while processing correlations.'
21475           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21476         endif ! msglen.eq.msglen1
21477       endif ! fg_rank.lt.nfgtasks-1
21478       if (ldone) goto 30
21479       ldone=.true.
21480       goto 10
21481    30 continue
21482 #endif
21483       if (lprn) then
21484         write (iout,'(a)') 'Contact function values:'
21485         do i=nnt_molec(2),nct_molec(2)-1
21486           write (iout,'(2i3,50(1x,i2,f5.2))') &
21487          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21488          j=1,num_cont_hb(i))
21489         enddo
21490       endif
21491       ecorr=0.0D0
21492       ecorr3=0.0d0
21493 !C Remove the loop below after debugging !!!
21494 !      do i=nnt_molec(2),nct_molec(2)
21495 !        do j=1,3
21496 !          gradcorr_nucl(j,i)=0.0D0
21497 !          gradxorr_nucl(j,i)=0.0D0
21498 !          gradcorr3_nucl(j,i)=0.0D0
21499 !          gradxorr3_nucl(j,i)=0.0D0
21500 !        enddo
21501 !      enddo
21502 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21503 !C Calculate the local-electrostatic correlation terms
21504       do i=iatsc_s_nucl,iatsc_e_nucl
21505         i1=i+1
21506         num_conti=num_cont_hb(i)
21507         num_conti1=num_cont_hb(i+1)
21508 !        print *,i,num_conti,num_conti1
21509         do jj=1,num_conti
21510           j=jcont_hb(jj,i)
21511           do kk=1,num_conti1
21512             j1=jcont_hb(kk,i1)
21513 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21514 !c     &         ' jj=',jj,' kk=',kk
21515             if (j1.eq.j+1 .or. j1.eq.j-1) then
21516 !C
21517 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21518 !C The system gains extra energy.
21519 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21520 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21521 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21522 !C
21523               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21524               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21525                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21526               n_corr=n_corr+1
21527             else if (j1.eq.j) then
21528 !C
21529 !C Contacts I-J and I-(J+1) occur simultaneously.
21530 !C The system loses extra energy.
21531 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21532 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21533 !C Need to implement full formulas 32 from Liwo et al., 1998.
21534 !C
21535 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21536 !c     &         ' jj=',jj,' kk=',kk
21537               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21538             endif
21539           enddo ! kk
21540           do kk=1,num_conti
21541             j1=jcont_hb(kk,i)
21542 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21543 !c     &         ' jj=',jj,' kk=',kk
21544             if (j1.eq.j+1) then
21545 !C Contacts I-J and (I+1)-J occur simultaneously.
21546 !C The system loses extra energy.
21547               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21548             endif ! j1==j+1
21549           enddo ! kk
21550         enddo ! jj
21551       enddo ! i
21552       return
21553       end subroutine multibody_hb_nucl
21554 !-----------------------------------------------------------
21555       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21556 !      implicit real*8 (a-h,o-z)
21557 !      include 'DIMENSIONS'
21558 !      include 'COMMON.IOUNITS'
21559 !      include 'COMMON.DERIV'
21560 !      include 'COMMON.INTERACT'
21561 !      include 'COMMON.CONTACTS'
21562       real(kind=8),dimension(3) :: gx,gx1
21563       logical :: lprn
21564 !el local variables
21565       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21566       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21567                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21568                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21569                    rlocshield
21570
21571       lprn=.false.
21572       eij=facont_hb(jj,i)
21573       ekl=facont_hb(kk,k)
21574       ees0pij=ees0p(jj,i)
21575       ees0pkl=ees0p(kk,k)
21576       ees0mij=ees0m(jj,i)
21577       ees0mkl=ees0m(kk,k)
21578       ekont=eij*ekl
21579       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21580 !      print *,"ehbcorr_nucl",ekont,ees
21581 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21582 !C Following 4 lines for diagnostics.
21583 !cd    ees0pkl=0.0D0
21584 !cd    ees0pij=1.0D0
21585 !cd    ees0mkl=0.0D0
21586 !cd    ees0mij=1.0D0
21587 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21588 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21589 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21590 !C Calculate the multi-body contribution to energy.
21591 !      ecorr_nucl=ecorr_nucl+ekont*ees
21592 !C Calculate multi-body contributions to the gradient.
21593       coeffpees0pij=coeffp*ees0pij
21594       coeffmees0mij=coeffm*ees0mij
21595       coeffpees0pkl=coeffp*ees0pkl
21596       coeffmees0mkl=coeffm*ees0mkl
21597       do ll=1,3
21598         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21599        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21600        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21601         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21602         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21603         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21604         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21605         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21606         coeffmees0mij*gacontm_hb1(ll,kk,k))
21607         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21608         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21609         coeffmees0mij*gacontm_hb2(ll,kk,k))
21610         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21611           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21612           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21613         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21614         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21615         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21616           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21617           coeffmees0mij*gacontm_hb3(ll,kk,k))
21618         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21619         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21620         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21621         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21622         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21623         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21624       enddo
21625       ehbcorr_nucl=ekont*ees
21626       return
21627       end function ehbcorr_nucl
21628 !-------------------------------------------------------------------------
21629
21630      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21631 !      implicit real*8 (a-h,o-z)
21632 !      include 'DIMENSIONS'
21633 !      include 'COMMON.IOUNITS'
21634 !      include 'COMMON.DERIV'
21635 !      include 'COMMON.INTERACT'
21636 !      include 'COMMON.CONTACTS'
21637       real(kind=8),dimension(3) :: gx,gx1
21638       logical :: lprn
21639 !el local variables
21640       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21641       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21642                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21643                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21644                    rlocshield
21645
21646       lprn=.false.
21647       eij=facont_hb(jj,i)
21648       ekl=facont_hb(kk,k)
21649       ees0pij=ees0p(jj,i)
21650       ees0pkl=ees0p(kk,k)
21651       ees0mij=ees0m(jj,i)
21652       ees0mkl=ees0m(kk,k)
21653       ekont=eij*ekl
21654       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21655 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21656 !C Following 4 lines for diagnostics.
21657 !cd    ees0pkl=0.0D0
21658 !cd    ees0pij=1.0D0
21659 !cd    ees0mkl=0.0D0
21660 !cd    ees0mij=1.0D0
21661 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21662 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21663 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21664 !C Calculate the multi-body contribution to energy.
21665 !      ecorr=ecorr+ekont*ees
21666 !C Calculate multi-body contributions to the gradient.
21667       coeffpees0pij=coeffp*ees0pij
21668       coeffmees0mij=coeffm*ees0mij
21669       coeffpees0pkl=coeffp*ees0pkl
21670       coeffmees0mkl=coeffm*ees0mkl
21671       do ll=1,3
21672         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21673        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21674        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21675         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21676         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21677         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21678         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21679         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21680         coeffmees0mij*gacontm_hb1(ll,kk,k))
21681         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21682         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21683         coeffmees0mij*gacontm_hb2(ll,kk,k))
21684         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21685           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21686           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21687         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21688         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21689         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21690           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21691           coeffmees0mij*gacontm_hb3(ll,kk,k))
21692         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21693         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21694         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21695         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21696         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21697         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21698       enddo
21699       ehbcorr3_nucl=ekont*ees
21700       return
21701       end function ehbcorr3_nucl
21702 #ifdef MPI
21703       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21704       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21705       real(kind=8):: buffer(dimen1,dimen2)
21706       num_kont=num_cont_hb(atom)
21707       do i=1,num_kont
21708         do k=1,8
21709           do j=1,3
21710             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21711           enddo ! j
21712         enddo ! k
21713         buffer(i,indx+25)=facont_hb(i,atom)
21714         buffer(i,indx+26)=ees0p(i,atom)
21715         buffer(i,indx+27)=ees0m(i,atom)
21716         buffer(i,indx+28)=d_cont(i,atom)
21717         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21718       enddo ! i
21719       buffer(1,indx+30)=dfloat(num_kont)
21720       return
21721       end subroutine pack_buffer
21722 !c------------------------------------------------------------------------------
21723       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21724       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21725       real(kind=8):: buffer(dimen1,dimen2)
21726 !      double precision zapas
21727 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21728 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21729 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21730 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21731       num_kont=buffer(1,indx+30)
21732       num_kont_old=num_cont_hb(atom)
21733       num_cont_hb(atom)=num_kont+num_kont_old
21734       do i=1,num_kont
21735         ii=i+num_kont_old
21736         do k=1,8
21737           do j=1,3
21738             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21739           enddo ! j
21740         enddo ! k
21741         facont_hb(ii,atom)=buffer(i,indx+25)
21742         ees0p(ii,atom)=buffer(i,indx+26)
21743         ees0m(ii,atom)=buffer(i,indx+27)
21744         d_cont(i,atom)=buffer(i,indx+28)
21745         jcont_hb(ii,atom)=buffer(i,indx+29)
21746       enddo ! i
21747       return
21748       end subroutine unpack_buffer
21749 !c------------------------------------------------------------------------------
21750 #endif
21751       subroutine ecatcat(ecationcation)
21752         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21753         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21754         r7,r4,ecationcation,k0,rcal
21755         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21756         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21757         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21758         gg,r
21759
21760         ecationcation=0.0d0
21761         if (nres_molec(5).eq.0) return
21762         rcat0=3.472
21763         epscalc=0.05
21764         r06 = rcat0**6
21765         r012 = r06**2
21766         k0 = 332.0*(2.0*2.0)/80.0
21767         itmp=0
21768
21769         do i=1,4
21770         itmp=itmp+nres_molec(i)
21771         enddo
21772 !        write(iout,*) "itmp",itmp
21773         do i=itmp+1,itmp+nres_molec(5)-1
21774
21775         xi=c(1,i)
21776         yi=c(2,i)
21777         zi=c(3,i)
21778
21779           xi=mod(xi,boxxsize)
21780           if (xi.lt.0) xi=xi+boxxsize
21781           yi=mod(yi,boxysize)
21782           if (yi.lt.0) yi=yi+boxysize
21783           zi=mod(zi,boxzsize)
21784           if (zi.lt.0) zi=zi+boxzsize
21785
21786           do j=i+1,itmp+nres_molec(5)
21787 !           print *,i,j,'catcat'
21788            xj=c(1,j)
21789            yj=c(2,j)
21790            zj=c(3,j)
21791           xj=dmod(xj,boxxsize)
21792           if (xj.lt.0) xj=xj+boxxsize
21793           yj=dmod(yj,boxysize)
21794           if (yj.lt.0) yj=yj+boxysize
21795           zj=dmod(zj,boxzsize)
21796           if (zj.lt.0) zj=zj+boxzsize
21797 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
21798       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21799       xj_safe=xj
21800       yj_safe=yj
21801       zj_safe=zj
21802       subchap=0
21803       do xshift=-1,1
21804       do yshift=-1,1
21805       do zshift=-1,1
21806           xj=xj_safe+xshift*boxxsize
21807           yj=yj_safe+yshift*boxysize
21808           zj=zj_safe+zshift*boxzsize
21809           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21810           if(dist_temp.lt.dist_init) then
21811             dist_init=dist_temp
21812             xj_temp=xj
21813             yj_temp=yj
21814             zj_temp=zj
21815             subchap=1
21816           endif
21817        enddo
21818        enddo
21819        enddo
21820        if (subchap.eq.1) then
21821           xj=xj_temp-xi
21822           yj=yj_temp-yi
21823           zj=zj_temp-zi
21824        else
21825           xj=xj_safe-xi
21826           yj=yj_safe-yi
21827           zj=zj_safe-zi
21828        endif
21829        rcal =xj**2+yj**2+zj**2
21830         ract=sqrt(rcal)
21831 !        rcat0=3.472
21832 !        epscalc=0.05
21833 !        r06 = rcat0**6
21834 !        r012 = r06**2
21835 !        k0 = 332*(2*2)/80
21836         Evan1cat=epscalc*(r012/rcal**6)
21837         Evan2cat=epscalc*2*(r06/rcal**3)
21838         Eeleccat=k0/ract
21839         r7 = rcal**7
21840         r4 = rcal**4
21841         r(1)=xj
21842         r(2)=yj
21843         r(3)=zj
21844         do k=1,3
21845           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21846           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21847           dEeleccat(k)=-k0*r(k)/ract**3
21848         enddo
21849         do k=1,3
21850           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21851           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
21852           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
21853         enddo
21854
21855 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
21856         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
21857        enddo
21858        enddo
21859        return
21860        end subroutine ecatcat
21861 !---------------------------------------------------------------------------
21862        subroutine ecat_prot(ecation_prot)
21863        integer i,j,k,subchap,itmp,inum
21864         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21865         r7,r4,ecationcation
21866         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21867         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
21868         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
21869         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
21870         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
21871         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
21872         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
21873         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
21874         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
21875         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
21876         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
21877         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21878         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
21879         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
21880         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
21881         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
21882         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
21883         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
21884         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
21885         dEvan1Cat
21886         real(kind=8),dimension(6) :: vcatprm
21887         ecation_prot=0.0d0
21888 ! first lets calculate interaction with peptide groups
21889         if (nres_molec(5).eq.0) return
21890          wconst=78
21891         wdip =1.092777950857032D2
21892         wdip=wdip/wconst
21893         wmodquad=-2.174122713004870D4
21894         wmodquad=wmodquad/wconst
21895         wquad1 = 3.901232068562804D1
21896         wquad1=wquad1/wconst
21897         wquad2 = 3
21898         wquad2=wquad2/wconst
21899         wvan1 = 0.1
21900         wvan2 = 6
21901         itmp=0
21902         do i=1,4
21903         itmp=itmp+nres_molec(i)
21904         enddo
21905 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
21906         do i=ibond_start,ibond_end
21907 !         cycle
21908          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
21909         xi=0.5d0*(c(1,i)+c(1,i+1))
21910         yi=0.5d0*(c(2,i)+c(2,i+1))
21911         zi=0.5d0*(c(3,i)+c(3,i+1))
21912           xi=mod(xi,boxxsize)
21913           if (xi.lt.0) xi=xi+boxxsize
21914           yi=mod(yi,boxysize)
21915           if (yi.lt.0) yi=yi+boxysize
21916           zi=mod(zi,boxzsize)
21917           if (zi.lt.0) zi=zi+boxzsize
21918
21919          do j=itmp+1,itmp+nres_molec(5)
21920            xj=c(1,j)
21921            yj=c(2,j)
21922            zj=c(3,j)
21923           xj=dmod(xj,boxxsize)
21924           if (xj.lt.0) xj=xj+boxxsize
21925           yj=dmod(yj,boxysize)
21926           if (yj.lt.0) yj=yj+boxysize
21927           zj=dmod(zj,boxzsize)
21928           if (zj.lt.0) zj=zj+boxzsize
21929       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21930       xj_safe=xj
21931       yj_safe=yj
21932       zj_safe=zj
21933       subchap=0
21934       do xshift=-1,1
21935       do yshift=-1,1
21936       do zshift=-1,1
21937           xj=xj_safe+xshift*boxxsize
21938           yj=yj_safe+yshift*boxysize
21939           zj=zj_safe+zshift*boxzsize
21940           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21941           if(dist_temp.lt.dist_init) then
21942             dist_init=dist_temp
21943             xj_temp=xj
21944             yj_temp=yj
21945             zj_temp=zj
21946             subchap=1
21947           endif
21948        enddo
21949        enddo
21950        enddo
21951        if (subchap.eq.1) then
21952           xj=xj_temp-xi
21953           yj=yj_temp-yi
21954           zj=zj_temp-zi
21955        else
21956           xj=xj_safe-xi
21957           yj=yj_safe-yi
21958           zj=zj_safe-zi
21959        endif
21960 !       enddo
21961 !       enddo
21962        rcpm = sqrt(xj**2+yj**2+zj**2)
21963        drcp_norm(1)=xj/rcpm
21964        drcp_norm(2)=yj/rcpm
21965        drcp_norm(3)=zj/rcpm
21966        dcmag=0.0
21967        do k=1,3
21968        dcmag=dcmag+dc(k,i)**2
21969        enddo
21970        dcmag=dsqrt(dcmag)
21971        do k=1,3
21972          myd_norm(k)=dc(k,i)/dcmag
21973        enddo
21974         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
21975         drcp_norm(3)*myd_norm(3)
21976         rsecp = rcpm**2
21977         Ir = 1.0d0/rcpm
21978         Irsecp = 1.0d0/rsecp
21979         Irthrp = Irsecp/rcpm
21980         Irfourp = Irthrp/rcpm
21981         Irfiftp = Irfourp/rcpm
21982         Irsistp=Irfiftp/rcpm
21983         Irseven=Irsistp/rcpm
21984         Irtwelv=Irsistp*Irsistp
21985         Irthir=Irtwelv/rcpm
21986         sin2thet = (1-costhet*costhet)
21987         sinthet=sqrt(sin2thet)
21988         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
21989              *sin2thet
21990         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
21991              2*wvan2**6*Irsistp)
21992         ecation_prot = ecation_prot+E1+E2
21993         dE1dr = -2*costhet*wdip*Irthrp-&
21994          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
21995         dE2dr = 3*wquad1*wquad2*Irfourp-     &
21996           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
21997         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
21998         do k=1,3
21999           drdpep(k) = -drcp_norm(k)
22000           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
22001           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
22002           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
22003           dEddci(k) = dEdcos*dcosddci(k)
22004         enddo
22005         do k=1,3
22006         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22007         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22008         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22009         enddo
22010        enddo ! j
22011        enddo ! i
22012 !------------------------------------------sidechains
22013 !        do i=1,nres_molec(1)
22014         do i=ibond_start,ibond_end
22015          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22016 !         cycle
22017 !        print *,i,ecation_prot
22018         xi=(c(1,i+nres))
22019         yi=(c(2,i+nres))
22020         zi=(c(3,i+nres))
22021           xi=mod(xi,boxxsize)
22022           if (xi.lt.0) xi=xi+boxxsize
22023           yi=mod(yi,boxysize)
22024           if (yi.lt.0) yi=yi+boxysize
22025           zi=mod(zi,boxzsize)
22026           if (zi.lt.0) zi=zi+boxzsize
22027           do k=1,3
22028             cm1(k)=dc(k,i+nres)
22029           enddo
22030            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22031          do j=itmp+1,itmp+nres_molec(5)
22032            xj=c(1,j)
22033            yj=c(2,j)
22034            zj=c(3,j)
22035           xj=dmod(xj,boxxsize)
22036           if (xj.lt.0) xj=xj+boxxsize
22037           yj=dmod(yj,boxysize)
22038           if (yj.lt.0) yj=yj+boxysize
22039           zj=dmod(zj,boxzsize)
22040           if (zj.lt.0) zj=zj+boxzsize
22041       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22042       xj_safe=xj
22043       yj_safe=yj
22044       zj_safe=zj
22045       subchap=0
22046       do xshift=-1,1
22047       do yshift=-1,1
22048       do zshift=-1,1
22049           xj=xj_safe+xshift*boxxsize
22050           yj=yj_safe+yshift*boxysize
22051           zj=zj_safe+zshift*boxzsize
22052           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22053           if(dist_temp.lt.dist_init) then
22054             dist_init=dist_temp
22055             xj_temp=xj
22056             yj_temp=yj
22057             zj_temp=zj
22058             subchap=1
22059           endif
22060        enddo
22061        enddo
22062        enddo
22063        if (subchap.eq.1) then
22064           xj=xj_temp-xi
22065           yj=yj_temp-yi
22066           zj=zj_temp-zi
22067        else
22068           xj=xj_safe-xi
22069           yj=yj_safe-yi
22070           zj=zj_safe-zi
22071        endif
22072 !       enddo
22073 !       enddo
22074          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22075             if(itype(i,1).eq.16) then
22076             inum=1
22077             else
22078             inum=2
22079             endif
22080             do k=1,6
22081             vcatprm(k)=catprm(k,inum)
22082             enddo
22083             dASGL=catprm(7,inum)
22084              do k=1,3
22085                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22086                 valpha(k)=c(k,i)
22087                 vcat(k)=c(k,j)
22088               enddo
22089                       do k=1,3
22090           dx(k) = vcat(k)-vcm(k)
22091         enddo
22092         do k=1,3
22093           v1(k)=(vcm(k)-valpha(k))
22094           v2(k)=(vcat(k)-valpha(k))
22095         enddo
22096         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22097         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22098         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22099
22100 !  The weights of the energy function calculated from
22101 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22102         wh2o=78
22103         wc = vcatprm(1)
22104         wc=wc/wh2o
22105         wdip =vcatprm(2)
22106         wdip=wdip/wh2o
22107         wquad1 =vcatprm(3)
22108         wquad1=wquad1/wh2o
22109         wquad2 = vcatprm(4)
22110         wquad2=wquad2/wh2o
22111         wquad2p = 1-wquad2
22112         wvan1 = vcatprm(5)
22113         wvan2 =vcatprm(6)
22114         opt = dx(1)**2+dx(2)**2
22115         rsecp = opt+dx(3)**2
22116         rs = sqrt(rsecp)
22117         rthrp = rsecp*rs
22118         rfourp = rthrp*rs
22119         rsixp = rfourp*rsecp
22120         reight=rsixp*rsecp
22121         Ir = 1.0d0/rs
22122         Irsecp = 1/rsecp
22123         Irthrp = Irsecp/rs
22124         Irfourp = Irthrp/rs
22125         Irsixp = 1/rsixp
22126         Ireight=1/reight
22127         Irtw=Irsixp*Irsixp
22128         Irthir=Irtw/rs
22129         Irfourt=Irthir/rs
22130         opt1 = (4*rs*dx(3)*wdip)
22131         opt2 = 6*rsecp*wquad1*opt
22132         opt3 = wquad1*wquad2p*Irsixp
22133         opt4 = (wvan1*wvan2**12)
22134         opt5 = opt4*12*Irfourt
22135         opt6 = 2*wvan1*wvan2**6
22136         opt7 = 6*opt6*Ireight
22137         opt8 = wdip/v1m
22138         opt10 = wdip/v2m
22139         opt11 = (rsecp*v2m)**2
22140         opt12 = (rsecp*v1m)**2
22141         opt14 = (v1m*v2m*rsecp)**2
22142         opt15 = -wquad1/v2m**2
22143         opt16 = (rthrp*(v1m*v2m)**2)**2
22144         opt17 = (v1m**2*rthrp)**2
22145         opt18 = -wquad1/rthrp
22146         opt19 = (v1m**2*v2m**2)**2
22147         Ec = wc*Ir
22148         do k=1,3
22149           dEcCat(k) = -(dx(k)*wc)*Irthrp
22150           dEcCm(k)=(dx(k)*wc)*Irthrp
22151           dEcCalp(k)=0.0d0
22152         enddo
22153         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22154         do k=1,3
22155           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22156                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22157           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22158                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22159           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22160                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22161                       *v1dpv2)/opt14
22162         enddo
22163         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22164         do k=1,3
22165           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22166                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22167                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22168           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22169                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22170                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22171           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22172                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22173                         v1dpv2**2)/opt19
22174         enddo
22175         Equad2=wquad1*wquad2p*Irthrp
22176         do k=1,3
22177           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22178           dEquad2Cm(k)=3*dx(k)*rs*opt3
22179           dEquad2Calp(k)=0.0d0
22180         enddo
22181         Evan1=opt4*Irtw
22182         do k=1,3
22183           dEvan1Cat(k)=-dx(k)*opt5
22184           dEvan1Cm(k)=dx(k)*opt5
22185           dEvan1Calp(k)=0.0d0
22186         enddo
22187         Evan2=-opt6*Irsixp
22188         do k=1,3
22189           dEvan2Cat(k)=dx(k)*opt7
22190           dEvan2Cm(k)=-dx(k)*opt7
22191           dEvan2Calp(k)=0.0d0
22192         enddo
22193         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22194 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22195
22196         do k=1,3
22197           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22198                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22199 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22200           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22201                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22202           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22203                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22204         enddo
22205             dscmag = 0.0d0
22206             do k=1,3
22207               dscvec(k) = dc(k,i+nres)
22208               dscmag = dscmag+dscvec(k)*dscvec(k)
22209             enddo
22210             dscmag3 = dscmag
22211             dscmag = sqrt(dscmag)
22212             dscmag3 = dscmag3*dscmag
22213             constA = 1.0d0+dASGL/dscmag
22214             constB = 0.0d0
22215             do k=1,3
22216               constB = constB+dscvec(k)*dEtotalCm(k)
22217             enddo
22218             constB = constB*dASGL/dscmag3
22219             do k=1,3
22220               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22221               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22222                constA*dEtotalCm(k)-constB*dscvec(k)
22223 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22224               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22225               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22226              enddo
22227         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22228            if(itype(i,1).eq.14) then
22229             inum=3
22230             else
22231             inum=4
22232             endif
22233             do k=1,6
22234             vcatprm(k)=catprm(k,inum)
22235             enddo
22236             dASGL=catprm(7,inum)
22237              do k=1,3
22238                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22239                 valpha(k)=c(k,i)
22240                 vcat(k)=c(k,j)
22241               enddo
22242
22243         do k=1,3
22244           dx(k) = vcat(k)-vcm(k)
22245         enddo
22246         do k=1,3
22247           v1(k)=(vcm(k)-valpha(k))
22248           v2(k)=(vcat(k)-valpha(k))
22249         enddo
22250         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22251         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22252         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22253 !  The weights of the energy function calculated from
22254 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22255         wh2o=78
22256         wdip =vcatprm(2)
22257         wdip=wdip/wh2o
22258         wquad1 =vcatprm(3)
22259         wquad1=wquad1/wh2o
22260         wquad2 = vcatprm(4)
22261         wquad2=wquad2/wh2o
22262         wquad2p = 1-wquad2
22263         wvan1 = vcatprm(5)
22264         wvan2 =vcatprm(6)
22265         opt = dx(1)**2+dx(2)**2
22266         rsecp = opt+dx(3)**2
22267         rs = sqrt(rsecp)
22268         rthrp = rsecp*rs
22269         rfourp = rthrp*rs
22270         rsixp = rfourp*rsecp
22271         reight=rsixp*rsecp
22272         Ir = 1.0d0/rs
22273         Irsecp = 1/rsecp
22274         Irthrp = Irsecp/rs
22275         Irfourp = Irthrp/rs
22276         Irsixp = 1/rsixp
22277         Ireight=1/reight
22278         Irtw=Irsixp*Irsixp
22279         Irthir=Irtw/rs
22280         Irfourt=Irthir/rs
22281         opt1 = (4*rs*dx(3)*wdip)
22282         opt2 = 6*rsecp*wquad1*opt
22283         opt3 = wquad1*wquad2p*Irsixp
22284         opt4 = (wvan1*wvan2**12)
22285         opt5 = opt4*12*Irfourt
22286         opt6 = 2*wvan1*wvan2**6
22287         opt7 = 6*opt6*Ireight
22288         opt8 = wdip/v1m
22289         opt10 = wdip/v2m
22290         opt11 = (rsecp*v2m)**2
22291         opt12 = (rsecp*v1m)**2
22292         opt14 = (v1m*v2m*rsecp)**2
22293         opt15 = -wquad1/v2m**2
22294         opt16 = (rthrp*(v1m*v2m)**2)**2
22295         opt17 = (v1m**2*rthrp)**2
22296         opt18 = -wquad1/rthrp
22297         opt19 = (v1m**2*v2m**2)**2
22298         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22299         do k=1,3
22300           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22301                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22302          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22303                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22304           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22305                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22306                       *v1dpv2)/opt14
22307         enddo
22308         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22309         do k=1,3
22310           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22311                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22312                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22313           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22314                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22315                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22316           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22317                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22318                         v1dpv2**2)/opt19
22319         enddo
22320         Equad2=wquad1*wquad2p*Irthrp
22321         do k=1,3
22322           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22323           dEquad2Cm(k)=3*dx(k)*rs*opt3
22324           dEquad2Calp(k)=0.0d0
22325         enddo
22326         Evan1=opt4*Irtw
22327         do k=1,3
22328           dEvan1Cat(k)=-dx(k)*opt5
22329           dEvan1Cm(k)=dx(k)*opt5
22330           dEvan1Calp(k)=0.0d0
22331         enddo
22332         Evan2=-opt6*Irsixp
22333         do k=1,3
22334           dEvan2Cat(k)=dx(k)*opt7
22335           dEvan2Cm(k)=-dx(k)*opt7
22336           dEvan2Calp(k)=0.0d0
22337         enddo
22338          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22339         do k=1,3
22340           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22341                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22342           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22343                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22344           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22345                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22346         enddo
22347             dscmag = 0.0d0
22348             do k=1,3
22349               dscvec(k) = c(k,i+nres)-c(k,i)
22350               dscmag = dscmag+dscvec(k)*dscvec(k)
22351             enddo
22352             dscmag3 = dscmag
22353             dscmag = sqrt(dscmag)
22354             dscmag3 = dscmag3*dscmag
22355             constA = 1+dASGL/dscmag
22356             constB = 0.0d0
22357             do k=1,3
22358               constB = constB+dscvec(k)*dEtotalCm(k)
22359             enddo
22360             constB = constB*dASGL/dscmag3
22361             do k=1,3
22362               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22363               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22364                constA*dEtotalCm(k)-constB*dscvec(k)
22365               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22366               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22367              enddo
22368            else
22369             rcal = 0.0d0
22370             do k=1,3
22371               r(k) = c(k,j)-c(k,i+nres)
22372               rcal = rcal+r(k)*r(k)
22373             enddo
22374             ract=sqrt(rcal)
22375             rocal=1.5
22376             epscalc=0.2
22377             r0p=0.5*(rocal+sig0(itype(i,1)))
22378             r06 = r0p**6
22379             r012 = r06*r06
22380             Evan1=epscalc*(r012/rcal**6)
22381             Evan2=epscalc*2*(r06/rcal**3)
22382             r4 = rcal**4
22383             r7 = rcal**7
22384             do k=1,3
22385               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22386               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22387             enddo
22388             do k=1,3
22389               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22390             enddo
22391                  ecation_prot = ecation_prot+ Evan1+Evan2
22392             do  k=1,3
22393                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22394                dEtotalCm(k)
22395               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22396               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22397              enddo
22398          endif ! 13-16 residues
22399        enddo !j
22400        enddo !i
22401        return
22402        end subroutine ecat_prot
22403
22404 !----------------------------------------------------------------------------
22405 !-----------------------------------------------------------------------------
22406 !-----------------------------------------------------------------------------
22407       subroutine eprot_sc_base(escbase)
22408       use calc_data
22409 !      implicit real*8 (a-h,o-z)
22410 !      include 'DIMENSIONS'
22411 !      include 'COMMON.GEO'
22412 !      include 'COMMON.VAR'
22413 !      include 'COMMON.LOCAL'
22414 !      include 'COMMON.CHAIN'
22415 !      include 'COMMON.DERIV'
22416 !      include 'COMMON.NAMES'
22417 !      include 'COMMON.INTERACT'
22418 !      include 'COMMON.IOUNITS'
22419 !      include 'COMMON.CALC'
22420 !      include 'COMMON.CONTROL'
22421 !      include 'COMMON.SBRIDGE'
22422       logical :: lprn
22423 !el local variables
22424       integer :: iint,itypi,itypi1,itypj,subchap
22425       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22426       real(kind=8) :: evdw,sig0ij
22427       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22428                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22429                     sslipi,sslipj,faclip
22430       integer :: ii
22431       real(kind=8) :: fracinbuf
22432        real (kind=8) :: escbase
22433        real (kind=8),dimension(4):: ener
22434        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22435        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22436         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22437         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22438         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22439         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22440         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22441         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22442        real(kind=8),dimension(3,2)::chead,erhead_tail
22443        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22444        integer troll
22445        eps_out=80.0d0
22446        escbase=0.0d0
22447 !       do i=1,nres_molec(1)
22448         do i=ibond_start,ibond_end
22449         if (itype(i,1).eq.ntyp1_molec(1)) cycle
22450         itypi  = itype(i,1)
22451         dxi    = dc_norm(1,nres+i)
22452         dyi    = dc_norm(2,nres+i)
22453         dzi    = dc_norm(3,nres+i)
22454         dsci_inv = vbld_inv(i+nres)
22455         xi=c(1,nres+i)
22456         yi=c(2,nres+i)
22457         zi=c(3,nres+i)
22458         xi=mod(xi,boxxsize)
22459          if (xi.lt.0) xi=xi+boxxsize
22460         yi=mod(yi,boxysize)
22461          if (yi.lt.0) yi=yi+boxysize
22462         zi=mod(zi,boxzsize)
22463          if (zi.lt.0) zi=zi+boxzsize
22464          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22465            itypj= itype(j,2)
22466            if (itype(j,2).eq.ntyp1_molec(2))cycle
22467            xj=c(1,j+nres)
22468            yj=c(2,j+nres)
22469            zj=c(3,j+nres)
22470            xj=dmod(xj,boxxsize)
22471            if (xj.lt.0) xj=xj+boxxsize
22472            yj=dmod(yj,boxysize)
22473            if (yj.lt.0) yj=yj+boxysize
22474            zj=dmod(zj,boxzsize)
22475            if (zj.lt.0) zj=zj+boxzsize
22476           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22477           xj_safe=xj
22478           yj_safe=yj
22479           zj_safe=zj
22480           subchap=0
22481
22482           do xshift=-1,1
22483           do yshift=-1,1
22484           do zshift=-1,1
22485           xj=xj_safe+xshift*boxxsize
22486           yj=yj_safe+yshift*boxysize
22487           zj=zj_safe+zshift*boxzsize
22488           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22489           if(dist_temp.lt.dist_init) then
22490             dist_init=dist_temp
22491             xj_temp=xj
22492             yj_temp=yj
22493             zj_temp=zj
22494             subchap=1
22495           endif
22496           enddo
22497           enddo
22498           enddo
22499           if (subchap.eq.1) then
22500           xj=xj_temp-xi
22501           yj=yj_temp-yi
22502           zj=zj_temp-zi
22503           else
22504           xj=xj_safe-xi
22505           yj=yj_safe-yi
22506           zj=zj_safe-zi
22507           endif
22508           dxj = dc_norm( 1, nres+j )
22509           dyj = dc_norm( 2, nres+j )
22510           dzj = dc_norm( 3, nres+j )
22511 !          print *,i,j,itypi,itypj
22512           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
22513           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
22514 !          d1i=0.0d0
22515 !          d1j=0.0d0
22516 !          BetaT = 1.0d0 / (298.0d0 * Rb)
22517 ! Gay-berne var's
22518           sig0ij = sigma_scbase( itypi,itypj )
22519           chi1   = chi_scbase( itypi, itypj,1 )
22520           chi2   = chi_scbase( itypi, itypj,2 )
22521 !          chi1=0.0d0
22522 !          chi2=0.0d0
22523           chi12  = chi1 * chi2
22524           chip1  = chipp_scbase( itypi, itypj,1 )
22525           chip2  = chipp_scbase( itypi, itypj,2 )
22526 !          chip1=0.0d0
22527 !          chip2=0.0d0
22528           chip12 = chip1 * chip2
22529 ! not used by momo potential, but needed by sc_angular which is shared
22530 ! by all energy_potential subroutines
22531           alf1   = 0.0d0
22532           alf2   = 0.0d0
22533           alf12  = 0.0d0
22534           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
22535 !       a12sq = a12sq * a12sq
22536 ! charge of amino acid itypi is...
22537           chis1 = chis_scbase(itypi,itypj,1)
22538           chis2 = chis_scbase(itypi,itypj,2)
22539           chis12 = chis1 * chis2
22540           sig1 = sigmap1_scbase(itypi,itypj)
22541           sig2 = sigmap2_scbase(itypi,itypj)
22542 !       write (*,*) "sig1 = ", sig1
22543 !       write (*,*) "sig2 = ", sig2
22544 ! alpha factors from Fcav/Gcav
22545           b1 = alphasur_scbase(1,itypi,itypj)
22546 !          b1=0.0d0
22547           b2 = alphasur_scbase(2,itypi,itypj)
22548           b3 = alphasur_scbase(3,itypi,itypj)
22549           b4 = alphasur_scbase(4,itypi,itypj)
22550 ! used to determine whether we want to do quadrupole calculations
22551 ! used by Fgb
22552        eps_in = epsintab_scbase(itypi,itypj)
22553        if (eps_in.eq.0.0) eps_in=1.0
22554        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22555 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
22556 !-------------------------------------------------------------------
22557 ! tail location and distance calculations
22558        DO k = 1,3
22559 ! location of polar head is computed by taking hydrophobic centre
22560 ! and moving by a d1 * dc_norm vector
22561 ! see unres publications for very informative images
22562         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
22563         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
22564 ! distance
22565 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22566 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22567         Rhead_distance(k) = chead(k,2) - chead(k,1)
22568        END DO
22569 ! pitagoras (root of sum of squares)
22570        Rhead = dsqrt( &
22571           (Rhead_distance(1)*Rhead_distance(1)) &
22572         + (Rhead_distance(2)*Rhead_distance(2)) &
22573         + (Rhead_distance(3)*Rhead_distance(3)))
22574 !-------------------------------------------------------------------
22575 ! zero everything that should be zero'ed
22576        evdwij = 0.0d0
22577        ECL = 0.0d0
22578        Elj = 0.0d0
22579        Equad = 0.0d0
22580        Epol = 0.0d0
22581        Fcav=0.0d0
22582        eheadtail = 0.0d0
22583        dGCLdOM1 = 0.0d0
22584        dGCLdOM2 = 0.0d0
22585        dGCLdOM12 = 0.0d0
22586        dPOLdOM1 = 0.0d0
22587        dPOLdOM2 = 0.0d0
22588           Fcav = 0.0d0
22589           dFdR = 0.0d0
22590           dCAVdOM1  = 0.0d0
22591           dCAVdOM2  = 0.0d0
22592           dCAVdOM12 = 0.0d0
22593           dscj_inv = vbld_inv(j+nres)
22594 !          print *,i,j,dscj_inv,dsci_inv
22595 ! rij holds 1/(distance of Calpha atoms)
22596           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22597           rij  = dsqrt(rrij)
22598 !----------------------------
22599           CALL sc_angular
22600 ! this should be in elgrad_init but om's are calculated by sc_angular
22601 ! which in turn is used by older potentials
22602 ! om = omega, sqom = om^2
22603           sqom1  = om1 * om1
22604           sqom2  = om2 * om2
22605           sqom12 = om12 * om12
22606
22607 ! now we calculate EGB - Gey-Berne
22608 ! It will be summed up in evdwij and saved in evdw
22609           sigsq     = 1.0D0  / sigsq
22610           sig       = sig0ij * dsqrt(sigsq)
22611 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22612           rij_shift = 1.0/rij - sig + sig0ij
22613           IF (rij_shift.le.0.0D0) THEN
22614            evdw = 1.0D20
22615            RETURN
22616           END IF
22617           sigder = -sig * sigsq
22618           rij_shift = 1.0D0 / rij_shift
22619           fac       = rij_shift**expon
22620           c1        = fac  * fac * aa_scbase(itypi,itypj)
22621 !          c1        = 0.0d0
22622           c2        = fac  * bb_scbase(itypi,itypj)
22623 !          c2        = 0.0d0
22624           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22625           eps2der   = eps3rt * evdwij
22626           eps3der   = eps2rt * evdwij
22627 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22628           evdwij    = eps2rt * eps3rt * evdwij
22629           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22630           fac    = -expon * (c1 + evdwij) * rij_shift
22631           sigder = fac * sigder
22632 !          fac    = rij * fac
22633 ! Calculate distance derivative
22634           gg(1) =  fac
22635           gg(2) =  fac
22636           gg(3) =  fac
22637 !          if (b2.gt.0.0) then
22638           fac = chis1 * sqom1 + chis2 * sqom2 &
22639           - 2.0d0 * chis12 * om1 * om2 * om12
22640 ! we will use pom later in Gcav, so dont mess with it!
22641           pom = 1.0d0 - chis1 * chis2 * sqom12
22642           Lambf = (1.0d0 - (fac / pom))
22643           Lambf = dsqrt(Lambf)
22644           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22645 !       write (*,*) "sparrow = ", sparrow
22646           Chif = 1.0d0/rij * sparrow
22647           ChiLambf = Chif * Lambf
22648           eagle = dsqrt(ChiLambf)
22649           bat = ChiLambf ** 11.0d0
22650           top = b1 * ( eagle + b2 * ChiLambf - b3 )
22651           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
22652           botsq = bot * bot
22653           Fcav = top / bot
22654 !          print *,i,j,Fcav
22655           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
22656           dbot = 12.0d0 * b4 * bat * Lambf
22657           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22658 !       dFdR = 0.0d0
22659 !      write (*,*) "dFcav/dR = ", dFdR
22660           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
22661           dbot = 12.0d0 * b4 * bat * Chif
22662           eagle = Lambf * pom
22663           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22664           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22665           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22666               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22667
22668           dFdL = ((dtop * bot - top * dbot) / botsq)
22669 !       dFdL = 0.0d0
22670           dCAVdOM1  = dFdL * ( dFdOM1 )
22671           dCAVdOM2  = dFdL * ( dFdOM2 )
22672           dCAVdOM12 = dFdL * ( dFdOM12 )
22673
22674           ertail(1) = xj*rij
22675           ertail(2) = yj*rij
22676           ertail(3) = zj*rij
22677 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
22678 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
22679 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
22680 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
22681 !           print *,"EOMY",eom1,eom2,eom12
22682 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22683 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
22684 ! here dtail=0.0
22685 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
22686 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22687        DO k = 1, 3
22688 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22689 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22690         pom = ertail(k)
22691 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22692         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22693                   - (( dFdR + gg(k) ) * pom)
22694 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22695 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22696 !     &             - ( dFdR * pom )
22697         pom = ertail(k)
22698 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22699         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22700                   + (( dFdR + gg(k) ) * pom)
22701 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22702 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22703 !c!     &             + ( dFdR * pom )
22704
22705         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22706                   - (( dFdR + gg(k) ) * ertail(k))
22707 !c!     &             - ( dFdR * ertail(k))
22708
22709         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22710                   + (( dFdR + gg(k) ) * ertail(k))
22711 !c!     &             + ( dFdR * ertail(k))
22712
22713         gg(k) = 0.0d0
22714 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22715 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22716       END DO
22717
22718 !          else
22719
22720 !          endif
22721 !Now dipole-dipole
22722          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
22723        w1 = wdipdip_scbase(1,itypi,itypj)
22724        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
22725        w3 = wdipdip_scbase(2,itypi,itypj)
22726 !c!-------------------------------------------------------------------
22727 !c! ECL
22728        fac = (om12 - 3.0d0 * om1 * om2)
22729        c1 = (w1 / (Rhead**3.0d0)) * fac
22730        c2 = (w2 / Rhead ** 6.0d0)  &
22731          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22732        c3= (w3/ Rhead ** 6.0d0)  &
22733          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22734        ECL = c1 - c2 + c3
22735 !c!       write (*,*) "w1 = ", w1
22736 !c!       write (*,*) "w2 = ", w2
22737 !c!       write (*,*) "om1 = ", om1
22738 !c!       write (*,*) "om2 = ", om2
22739 !c!       write (*,*) "om12 = ", om12
22740 !c!       write (*,*) "fac = ", fac
22741 !c!       write (*,*) "c1 = ", c1
22742 !c!       write (*,*) "c2 = ", c2
22743 !c!       write (*,*) "Ecl = ", Ecl
22744 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
22745 !c!       write (*,*) "c2_2 = ",
22746 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22747 !c!-------------------------------------------------------------------
22748 !c! dervative of ECL is GCL...
22749 !c! dECL/dr
22750        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
22751        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
22752          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
22753        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
22754          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22755        dGCLdR = c1 - c2 + c3
22756 !c! dECL/dom1
22757        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
22758        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22759          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
22760        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
22761        dGCLdOM1 = c1 - c2 + c3
22762 !c! dECL/dom2
22763        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
22764        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22765          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
22766        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
22767        dGCLdOM2 = c1 - c2 + c3
22768 !c! dECL/dom12
22769        c1 = w1 / (Rhead ** 3.0d0)
22770        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
22771        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
22772        dGCLdOM12 = c1 - c2 + c3
22773        DO k= 1, 3
22774         erhead(k) = Rhead_distance(k)/Rhead
22775        END DO
22776        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22777        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22778        facd1 = d1i * vbld_inv(i+nres)
22779        facd2 = d1j * vbld_inv(j+nres)
22780        DO k = 1, 3
22781
22782         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22783         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22784                   - dGCLdR * pom
22785         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22786         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22787                   + dGCLdR * pom
22788
22789         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22790                   - dGCLdR * erhead(k)
22791         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22792                   + dGCLdR * erhead(k)
22793        END DO
22794        endif
22795 !now charge with dipole eg. ARG-dG
22796        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
22797       alphapol1 = alphapol_scbase(itypi,itypj)
22798        w1        = wqdip_scbase(1,itypi,itypj)
22799        w2        = wqdip_scbase(2,itypi,itypj)
22800 !       w1=0.0d0
22801 !       w2=0.0d0
22802 !       pis       = sig0head_scbase(itypi,itypj)
22803 !       eps_head   = epshead_scbase(itypi,itypj)
22804 !c!-------------------------------------------------------------------
22805 !c! R1 - distance between head of ith side chain and tail of jth sidechain
22806        R1 = 0.0d0
22807        DO k = 1, 3
22808 !c! Calculate head-to-tail distances tail is center of side-chain
22809         R1=R1+(c(k,j+nres)-chead(k,1))**2
22810        END DO
22811 !c! Pitagoras
22812        R1 = dsqrt(R1)
22813
22814 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
22815 !c!     &        +dhead(1,1,itypi,itypj))**2))
22816 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
22817 !c!     &        +dhead(2,1,itypi,itypj))**2))
22818
22819 !c!-------------------------------------------------------------------
22820 !c! ecl
22821        sparrow  = w1  *  om1
22822        hawk     = w2 *  (1.0d0 - sqom2)
22823        Ecl = sparrow / Rhead**2.0d0 &
22824            - hawk    / Rhead**4.0d0
22825 !c!-------------------------------------------------------------------
22826 !c! derivative of ecl is Gcl
22827 !c! dF/dr part
22828        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
22829                 + 4.0d0 * hawk    / Rhead**5.0d0
22830 !c! dF/dom1
22831        dGCLdOM1 = (w1) / (Rhead**2.0d0)
22832 !c! dF/dom2
22833        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
22834 !c--------------------------------------------------------------------
22835 !c Polarization energy
22836 !c Epol
22837        MomoFac1 = (1.0d0 - chi1 * sqom2)
22838        RR1  = R1 * R1 / MomoFac1
22839        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
22840        fgb1 = sqrt( RR1 + a12sq * ee1)
22841 !       eps_inout_fac=0.0d0
22842        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
22843 ! derivative of Epol is Gpol...
22844        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
22845                 / (fgb1 ** 5.0d0)
22846        dFGBdR1 = ( (R1 / MomoFac1) &
22847              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
22848              / ( 2.0d0 * fgb1 )
22849        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
22850                * (2.0d0 - 0.5d0 * ee1) ) &
22851                / (2.0d0 * fgb1)
22852        dPOLdR1 = dPOLdFGB1 * dFGBdR1
22853 !       dPOLdR1 = 0.0d0
22854        dPOLdOM1 = 0.0d0
22855        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
22856        DO k = 1, 3
22857         erhead(k) = Rhead_distance(k)/Rhead
22858         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
22859        END DO
22860
22861        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22862        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22863        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
22864 !       bat=0.0d0
22865        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
22866        facd1 = d1i * vbld_inv(i+nres)
22867        facd2 = d1j * vbld_inv(j+nres)
22868 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22869
22870        DO k = 1, 3
22871         hawk = (erhead_tail(k,1) + &
22872         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
22873 !        facd1=0.0d0
22874 !        facd2=0.0d0
22875         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22876         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
22877                    - dGCLdR * pom &
22878                    - dPOLdR1 *  (erhead_tail(k,1))
22879 !     &             - dGLJdR * pom
22880
22881         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22882         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
22883                    + dGCLdR * pom  &
22884                    + dPOLdR1 * (erhead_tail(k,1))
22885 !     &             + dGLJdR * pom
22886
22887
22888         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
22889                   - dGCLdR * erhead(k) &
22890                   - dPOLdR1 * erhead_tail(k,1)
22891 !     &             - dGLJdR * erhead(k)
22892
22893         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
22894                   + dGCLdR * erhead(k)  &
22895                   + dPOLdR1 * erhead_tail(k,1)
22896 !     &             + dGLJdR * erhead(k)
22897
22898        END DO
22899        endif
22900 !       print *,i,j,evdwij,epol,Fcav,ECL
22901        escbase=escbase+evdwij+epol+Fcav+ECL
22902        call sc_grad_scbase
22903          enddo
22904       enddo
22905
22906       return
22907       end subroutine eprot_sc_base
22908       SUBROUTINE sc_grad_scbase
22909       use calc_data
22910
22911        real (kind=8) :: dcosom1(3),dcosom2(3)
22912        eom1  =    &
22913               eps2der * eps2rt_om1   &
22914             - 2.0D0 * alf1 * eps3der &
22915             + sigder * sigsq_om1     &
22916             + dCAVdOM1               &
22917             + dGCLdOM1               &
22918             + dPOLdOM1
22919
22920        eom2  =  &
22921               eps2der * eps2rt_om2   &
22922             + 2.0D0 * alf2 * eps3der &
22923             + sigder * sigsq_om2     &
22924             + dCAVdOM2               &
22925             + dGCLdOM2               &
22926             + dPOLdOM2
22927
22928        eom12 =    &
22929               evdwij  * eps1_om12     &
22930             + eps2der * eps2rt_om12   &
22931             - 2.0D0 * alf12 * eps3der &
22932             + sigder *sigsq_om12      &
22933             + dCAVdOM12               &
22934             + dGCLdOM12
22935
22936 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
22937 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
22938 !               gg(1),gg(2),"rozne"
22939        DO k = 1, 3
22940         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
22941         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
22942         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
22943         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
22944                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22945                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22946         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
22947                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22948                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22949         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
22950         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
22951        END DO
22952        RETURN
22953       END SUBROUTINE sc_grad_scbase
22954
22955
22956       subroutine epep_sc_base(epepbase)
22957       use calc_data
22958       logical :: lprn
22959 !el local variables
22960       integer :: iint,itypi,itypi1,itypj,subchap
22961       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22962       real(kind=8) :: evdw,sig0ij
22963       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22964                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22965                     sslipi,sslipj,faclip
22966       integer :: ii
22967       real(kind=8) :: fracinbuf
22968        real (kind=8) :: epepbase
22969        real (kind=8),dimension(4):: ener
22970        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22971        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22972         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22973         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22974         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22975         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22976         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22977         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22978        real(kind=8),dimension(3,2)::chead,erhead_tail
22979        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22980        integer troll
22981        eps_out=80.0d0
22982        epepbase=0.0d0
22983 !       do i=1,nres_molec(1)-1
22984         do i=ibond_start,ibond_end
22985         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
22986 !C        itypi  = itype(i,1)
22987         dxi    = dc_norm(1,i)
22988         dyi    = dc_norm(2,i)
22989         dzi    = dc_norm(3,i)
22990 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
22991         dsci_inv = vbld_inv(i+1)/2.0
22992         xi=(c(1,i)+c(1,i+1))/2.0
22993         yi=(c(2,i)+c(2,i+1))/2.0
22994         zi=(c(3,i)+c(3,i+1))/2.0
22995         xi=mod(xi,boxxsize)
22996          if (xi.lt.0) xi=xi+boxxsize
22997         yi=mod(yi,boxysize)
22998          if (yi.lt.0) yi=yi+boxysize
22999         zi=mod(zi,boxzsize)
23000          if (zi.lt.0) zi=zi+boxzsize
23001          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23002            itypj= itype(j,2)
23003            if (itype(j,2).eq.ntyp1_molec(2))cycle
23004            xj=c(1,j+nres)
23005            yj=c(2,j+nres)
23006            zj=c(3,j+nres)
23007            xj=dmod(xj,boxxsize)
23008            if (xj.lt.0) xj=xj+boxxsize
23009            yj=dmod(yj,boxysize)
23010            if (yj.lt.0) yj=yj+boxysize
23011            zj=dmod(zj,boxzsize)
23012            if (zj.lt.0) zj=zj+boxzsize
23013           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23014           xj_safe=xj
23015           yj_safe=yj
23016           zj_safe=zj
23017           subchap=0
23018
23019           do xshift=-1,1
23020           do yshift=-1,1
23021           do zshift=-1,1
23022           xj=xj_safe+xshift*boxxsize
23023           yj=yj_safe+yshift*boxysize
23024           zj=zj_safe+zshift*boxzsize
23025           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23026           if(dist_temp.lt.dist_init) then
23027             dist_init=dist_temp
23028             xj_temp=xj
23029             yj_temp=yj
23030             zj_temp=zj
23031             subchap=1
23032           endif
23033           enddo
23034           enddo
23035           enddo
23036           if (subchap.eq.1) then
23037           xj=xj_temp-xi
23038           yj=yj_temp-yi
23039           zj=zj_temp-zi
23040           else
23041           xj=xj_safe-xi
23042           yj=yj_safe-yi
23043           zj=zj_safe-zi
23044           endif
23045           dxj = dc_norm( 1, nres+j )
23046           dyj = dc_norm( 2, nres+j )
23047           dzj = dc_norm( 3, nres+j )
23048 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23049 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23050
23051 ! Gay-berne var's
23052           sig0ij = sigma_pepbase(itypj )
23053           chi1   = chi_pepbase(itypj,1 )
23054           chi2   = chi_pepbase(itypj,2 )
23055 !          chi1=0.0d0
23056 !          chi2=0.0d0
23057           chi12  = chi1 * chi2
23058           chip1  = chipp_pepbase(itypj,1 )
23059           chip2  = chipp_pepbase(itypj,2 )
23060 !          chip1=0.0d0
23061 !          chip2=0.0d0
23062           chip12 = chip1 * chip2
23063           chis1 = chis_pepbase(itypj,1)
23064           chis2 = chis_pepbase(itypj,2)
23065           chis12 = chis1 * chis2
23066           sig1 = sigmap1_pepbase(itypj)
23067           sig2 = sigmap2_pepbase(itypj)
23068 !       write (*,*) "sig1 = ", sig1
23069 !       write (*,*) "sig2 = ", sig2
23070        DO k = 1,3
23071 ! location of polar head is computed by taking hydrophobic centre
23072 ! and moving by a d1 * dc_norm vector
23073 ! see unres publications for very informative images
23074         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23075 ! + d1i * dc_norm(k, i+nres)
23076         chead(k,2) = c(k, j+nres)
23077 ! + d1j * dc_norm(k, j+nres)
23078 ! distance
23079 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23080 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23081         Rhead_distance(k) = chead(k,2) - chead(k,1)
23082 !        print *,gvdwc_pepbase(k,i)
23083
23084        END DO
23085        Rhead = dsqrt( &
23086           (Rhead_distance(1)*Rhead_distance(1)) &
23087         + (Rhead_distance(2)*Rhead_distance(2)) &
23088         + (Rhead_distance(3)*Rhead_distance(3)))
23089
23090 ! alpha factors from Fcav/Gcav
23091           b1 = alphasur_pepbase(1,itypj)
23092 !          b1=0.0d0
23093           b2 = alphasur_pepbase(2,itypj)
23094           b3 = alphasur_pepbase(3,itypj)
23095           b4 = alphasur_pepbase(4,itypj)
23096           alf1   = 0.0d0
23097           alf2   = 0.0d0
23098           alf12  = 0.0d0
23099           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23100 !          print *,i,j,rrij
23101           rij  = dsqrt(rrij)
23102 !----------------------------
23103        evdwij = 0.0d0
23104        ECL = 0.0d0
23105        Elj = 0.0d0
23106        Equad = 0.0d0
23107        Epol = 0.0d0
23108        Fcav=0.0d0
23109        eheadtail = 0.0d0
23110        dGCLdOM1 = 0.0d0
23111        dGCLdOM2 = 0.0d0
23112        dGCLdOM12 = 0.0d0
23113        dPOLdOM1 = 0.0d0
23114        dPOLdOM2 = 0.0d0
23115           Fcav = 0.0d0
23116           dFdR = 0.0d0
23117           dCAVdOM1  = 0.0d0
23118           dCAVdOM2  = 0.0d0
23119           dCAVdOM12 = 0.0d0
23120           dscj_inv = vbld_inv(j+nres)
23121           CALL sc_angular
23122 ! this should be in elgrad_init but om's are calculated by sc_angular
23123 ! which in turn is used by older potentials
23124 ! om = omega, sqom = om^2
23125           sqom1  = om1 * om1
23126           sqom2  = om2 * om2
23127           sqom12 = om12 * om12
23128
23129 ! now we calculate EGB - Gey-Berne
23130 ! It will be summed up in evdwij and saved in evdw
23131           sigsq     = 1.0D0  / sigsq
23132           sig       = sig0ij * dsqrt(sigsq)
23133           rij_shift = 1.0/rij - sig + sig0ij
23134           IF (rij_shift.le.0.0D0) THEN
23135            evdw = 1.0D20
23136            RETURN
23137           END IF
23138           sigder = -sig * sigsq
23139           rij_shift = 1.0D0 / rij_shift
23140           fac       = rij_shift**expon
23141           c1        = fac  * fac * aa_pepbase(itypj)
23142 !          c1        = 0.0d0
23143           c2        = fac  * bb_pepbase(itypj)
23144 !          c2        = 0.0d0
23145           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23146           eps2der   = eps3rt * evdwij
23147           eps3der   = eps2rt * evdwij
23148 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23149           evdwij    = eps2rt * eps3rt * evdwij
23150           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23151           fac    = -expon * (c1 + evdwij) * rij_shift
23152           sigder = fac * sigder
23153 !          fac    = rij * fac
23154 ! Calculate distance derivative
23155           gg(1) =  fac
23156           gg(2) =  fac
23157           gg(3) =  fac
23158           fac = chis1 * sqom1 + chis2 * sqom2 &
23159           - 2.0d0 * chis12 * om1 * om2 * om12
23160 ! we will use pom later in Gcav, so dont mess with it!
23161           pom = 1.0d0 - chis1 * chis2 * sqom12
23162           Lambf = (1.0d0 - (fac / pom))
23163           Lambf = dsqrt(Lambf)
23164           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23165 !       write (*,*) "sparrow = ", sparrow
23166           Chif = 1.0d0/rij * sparrow
23167           ChiLambf = Chif * Lambf
23168           eagle = dsqrt(ChiLambf)
23169           bat = ChiLambf ** 11.0d0
23170           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23171           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23172           botsq = bot * bot
23173           Fcav = top / bot
23174 !          print *,i,j,Fcav
23175           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23176           dbot = 12.0d0 * b4 * bat * Lambf
23177           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23178 !       dFdR = 0.0d0
23179 !      write (*,*) "dFcav/dR = ", dFdR
23180           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23181           dbot = 12.0d0 * b4 * bat * Chif
23182           eagle = Lambf * pom
23183           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23184           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23185           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23186               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23187
23188           dFdL = ((dtop * bot - top * dbot) / botsq)
23189 !       dFdL = 0.0d0
23190           dCAVdOM1  = dFdL * ( dFdOM1 )
23191           dCAVdOM2  = dFdL * ( dFdOM2 )
23192           dCAVdOM12 = dFdL * ( dFdOM12 )
23193
23194           ertail(1) = xj*rij
23195           ertail(2) = yj*rij
23196           ertail(3) = zj*rij
23197        DO k = 1, 3
23198 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23199 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23200         pom = ertail(k)
23201 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23202         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23203                   - (( dFdR + gg(k) ) * pom)/2.0
23204 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
23205 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23206 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23207 !     &             - ( dFdR * pom )
23208         pom = ertail(k)
23209 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23210         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23211                   + (( dFdR + gg(k) ) * pom)
23212 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23213 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23214 !c!     &             + ( dFdR * pom )
23215
23216         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23217                   - (( dFdR + gg(k) ) * ertail(k))/2.0
23218 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
23219
23220 !c!     &             - ( dFdR * ertail(k))
23221
23222         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23223                   + (( dFdR + gg(k) ) * ertail(k))
23224 !c!     &             + ( dFdR * ertail(k))
23225
23226         gg(k) = 0.0d0
23227 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23228 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23229       END DO
23230
23231
23232        w1 = wdipdip_pepbase(1,itypj)
23233        w2 = -wdipdip_pepbase(3,itypj)/2.0
23234        w3 = wdipdip_pepbase(2,itypj)
23235 !       w1=0.0d0
23236 !       w2=0.0d0
23237 !c!-------------------------------------------------------------------
23238 !c! ECL
23239 !       w3=0.0d0
23240        fac = (om12 - 3.0d0 * om1 * om2)
23241        c1 = (w1 / (Rhead**3.0d0)) * fac
23242        c2 = (w2 / Rhead ** 6.0d0)  &
23243          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23244        c3= (w3/ Rhead ** 6.0d0)  &
23245          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23246
23247        ECL = c1 - c2 + c3
23248
23249        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23250        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23251          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23252        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23253          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23254
23255        dGCLdR = c1 - c2 + c3
23256 !c! dECL/dom1
23257        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23258        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23259          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23260        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23261        dGCLdOM1 = c1 - c2 + c3
23262 !c! dECL/dom2
23263        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23264        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23265          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23266        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23267
23268        dGCLdOM2 = c1 - c2 + c3
23269 !c! dECL/dom12
23270        c1 = w1 / (Rhead ** 3.0d0)
23271        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23272        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23273        dGCLdOM12 = c1 - c2 + c3
23274        DO k= 1, 3
23275         erhead(k) = Rhead_distance(k)/Rhead
23276        END DO
23277        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23278        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23279 !       facd1 = d1 * vbld_inv(i+nres)
23280 !       facd2 = d2 * vbld_inv(j+nres)
23281        DO k = 1, 3
23282
23283 !        pom = erhead(k)
23284 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23285 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
23286 !                  - dGCLdR * pom
23287         pom = erhead(k)
23288 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23289         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23290                   + dGCLdR * pom
23291
23292         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23293                   - dGCLdR * erhead(k)/2.0d0
23294 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23295         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23296                   - dGCLdR * erhead(k)/2.0d0
23297 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23298         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23299                   + dGCLdR * erhead(k)
23300        END DO
23301 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
23302        epepbase=epepbase+evdwij+Fcav+ECL
23303        call sc_grad_pepbase
23304        enddo
23305        enddo
23306       END SUBROUTINE epep_sc_base
23307       SUBROUTINE sc_grad_pepbase
23308       use calc_data
23309
23310        real (kind=8) :: dcosom1(3),dcosom2(3)
23311        eom1  =    &
23312               eps2der * eps2rt_om1   &
23313             - 2.0D0 * alf1 * eps3der &
23314             + sigder * sigsq_om1     &
23315             + dCAVdOM1               &
23316             + dGCLdOM1               &
23317             + dPOLdOM1
23318
23319        eom2  =  &
23320               eps2der * eps2rt_om2   &
23321             + 2.0D0 * alf2 * eps3der &
23322             + sigder * sigsq_om2     &
23323             + dCAVdOM2               &
23324             + dGCLdOM2               &
23325             + dPOLdOM2
23326
23327        eom12 =    &
23328               evdwij  * eps1_om12     &
23329             + eps2der * eps2rt_om12   &
23330             - 2.0D0 * alf12 * eps3der &
23331             + sigder *sigsq_om12      &
23332             + dCAVdOM12               &
23333             + dGCLdOM12
23334 !        om12=0.0
23335 !        eom12=0.0
23336 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23337 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
23338 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23339 !                 *dsci_inv*2.0
23340 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23341 !               gg(1),gg(2),"rozne"
23342        DO k = 1, 3
23343         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
23344         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23345         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23346         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
23347                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23348                  *dsci_inv*2.0 &
23349                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23350         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
23351                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
23352                  *dsci_inv*2.0 &
23353                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23354 !         print *,eom12,eom2,om12,om2
23355 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23356 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23357         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
23358                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23359                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23360         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
23361        END DO
23362        RETURN
23363       END SUBROUTINE sc_grad_pepbase
23364       subroutine eprot_sc_phosphate(escpho)
23365       use calc_data
23366 !      implicit real*8 (a-h,o-z)
23367 !      include 'DIMENSIONS'
23368 !      include 'COMMON.GEO'
23369 !      include 'COMMON.VAR'
23370 !      include 'COMMON.LOCAL'
23371 !      include 'COMMON.CHAIN'
23372 !      include 'COMMON.DERIV'
23373 !      include 'COMMON.NAMES'
23374 !      include 'COMMON.INTERACT'
23375 !      include 'COMMON.IOUNITS'
23376 !      include 'COMMON.CALC'
23377 !      include 'COMMON.CONTROL'
23378 !      include 'COMMON.SBRIDGE'
23379       logical :: lprn
23380 !el local variables
23381       integer :: iint,itypi,itypi1,itypj,subchap
23382       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23383       real(kind=8) :: evdw,sig0ij
23384       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23385                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23386                     sslipi,sslipj,faclip,alpha_sco
23387       integer :: ii
23388       real(kind=8) :: fracinbuf
23389        real (kind=8) :: escpho
23390        real (kind=8),dimension(4):: ener
23391        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23392        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23393         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23394         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23395         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23396         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23397         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23398         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23399        real(kind=8),dimension(3,2)::chead,erhead_tail
23400        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23401        integer troll
23402        eps_out=80.0d0
23403        escpho=0.0d0
23404 !       do i=1,nres_molec(1)
23405         do i=ibond_start,ibond_end
23406         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23407         itypi  = itype(i,1)
23408         dxi    = dc_norm(1,nres+i)
23409         dyi    = dc_norm(2,nres+i)
23410         dzi    = dc_norm(3,nres+i)
23411         dsci_inv = vbld_inv(i+nres)
23412         xi=c(1,nres+i)
23413         yi=c(2,nres+i)
23414         zi=c(3,nres+i)
23415         xi=mod(xi,boxxsize)
23416          if (xi.lt.0) xi=xi+boxxsize
23417         yi=mod(yi,boxysize)
23418          if (yi.lt.0) yi=yi+boxysize
23419         zi=mod(zi,boxzsize)
23420          if (zi.lt.0) zi=zi+boxzsize
23421          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23422            itypj= itype(j,2)
23423            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23424             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23425            xj=(c(1,j)+c(1,j+1))/2.0
23426            yj=(c(2,j)+c(2,j+1))/2.0
23427            zj=(c(3,j)+c(3,j+1))/2.0
23428            xj=dmod(xj,boxxsize)
23429            if (xj.lt.0) xj=xj+boxxsize
23430            yj=dmod(yj,boxysize)
23431            if (yj.lt.0) yj=yj+boxysize
23432            zj=dmod(zj,boxzsize)
23433            if (zj.lt.0) zj=zj+boxzsize
23434           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23435           xj_safe=xj
23436           yj_safe=yj
23437           zj_safe=zj
23438           subchap=0
23439           do xshift=-1,1
23440           do yshift=-1,1
23441           do zshift=-1,1
23442           xj=xj_safe+xshift*boxxsize
23443           yj=yj_safe+yshift*boxysize
23444           zj=zj_safe+zshift*boxzsize
23445           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23446           if(dist_temp.lt.dist_init) then
23447             dist_init=dist_temp
23448             xj_temp=xj
23449             yj_temp=yj
23450             zj_temp=zj
23451             subchap=1
23452           endif
23453           enddo
23454           enddo
23455           enddo
23456           if (subchap.eq.1) then
23457           xj=xj_temp-xi
23458           yj=yj_temp-yi
23459           zj=zj_temp-zi
23460           else
23461           xj=xj_safe-xi
23462           yj=yj_safe-yi
23463           zj=zj_safe-zi
23464           endif
23465           dxj = dc_norm( 1,j )
23466           dyj = dc_norm( 2,j )
23467           dzj = dc_norm( 3,j )
23468           dscj_inv = vbld_inv(j+1)
23469
23470 ! Gay-berne var's
23471           sig0ij = sigma_scpho(itypi )
23472           chi1   = chi_scpho(itypi,1 )
23473           chi2   = chi_scpho(itypi,2 )
23474 !          chi1=0.0d0
23475 !          chi2=0.0d0
23476           chi12  = chi1 * chi2
23477           chip1  = chipp_scpho(itypi,1 )
23478           chip2  = chipp_scpho(itypi,2 )
23479 !          chip1=0.0d0
23480 !          chip2=0.0d0
23481           chip12 = chip1 * chip2
23482           chis1 = chis_scpho(itypi,1)
23483           chis2 = chis_scpho(itypi,2)
23484           chis12 = chis1 * chis2
23485           sig1 = sigmap1_scpho(itypi)
23486           sig2 = sigmap2_scpho(itypi)
23487 !       write (*,*) "sig1 = ", sig1
23488 !       write (*,*) "sig1 = ", sig1
23489 !       write (*,*) "sig2 = ", sig2
23490 ! alpha factors from Fcav/Gcav
23491           alf1   = 0.0d0
23492           alf2   = 0.0d0
23493           alf12  = 0.0d0
23494           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
23495
23496           b1 = alphasur_scpho(1,itypi)
23497 !          b1=0.0d0
23498           b2 = alphasur_scpho(2,itypi)
23499           b3 = alphasur_scpho(3,itypi)
23500           b4 = alphasur_scpho(4,itypi)
23501 ! used to determine whether we want to do quadrupole calculations
23502 ! used by Fgb
23503        eps_in = epsintab_scpho(itypi)
23504        if (eps_in.eq.0.0) eps_in=1.0
23505        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23506 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23507 !-------------------------------------------------------------------
23508 ! tail location and distance calculations
23509           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
23510           d1j = 0.0
23511        DO k = 1,3
23512 ! location of polar head is computed by taking hydrophobic centre
23513 ! and moving by a d1 * dc_norm vector
23514 ! see unres publications for very informative images
23515         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23516         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
23517 ! distance
23518 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23519 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23520         Rhead_distance(k) = chead(k,2) - chead(k,1)
23521        END DO
23522 ! pitagoras (root of sum of squares)
23523        Rhead = dsqrt( &
23524           (Rhead_distance(1)*Rhead_distance(1)) &
23525         + (Rhead_distance(2)*Rhead_distance(2)) &
23526         + (Rhead_distance(3)*Rhead_distance(3)))
23527        Rhead_sq=Rhead**2.0
23528 !-------------------------------------------------------------------
23529 ! zero everything that should be zero'ed
23530        evdwij = 0.0d0
23531        ECL = 0.0d0
23532        Elj = 0.0d0
23533        Equad = 0.0d0
23534        Epol = 0.0d0
23535        Fcav=0.0d0
23536        eheadtail = 0.0d0
23537        dGCLdR=0.0d0
23538        dGCLdOM1 = 0.0d0
23539        dGCLdOM2 = 0.0d0
23540        dGCLdOM12 = 0.0d0
23541        dPOLdOM1 = 0.0d0
23542        dPOLdOM2 = 0.0d0
23543           Fcav = 0.0d0
23544           dFdR = 0.0d0
23545           dCAVdOM1  = 0.0d0
23546           dCAVdOM2  = 0.0d0
23547           dCAVdOM12 = 0.0d0
23548           dscj_inv = vbld_inv(j+1)/2.0
23549 !dhead_scbasej(itypi,itypj)
23550 !          print *,i,j,dscj_inv,dsci_inv
23551 ! rij holds 1/(distance of Calpha atoms)
23552           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23553           rij  = dsqrt(rrij)
23554 !----------------------------
23555           CALL sc_angular
23556 ! this should be in elgrad_init but om's are calculated by sc_angular
23557 ! which in turn is used by older potentials
23558 ! om = omega, sqom = om^2
23559           sqom1  = om1 * om1
23560           sqom2  = om2 * om2
23561           sqom12 = om12 * om12
23562
23563 ! now we calculate EGB - Gey-Berne
23564 ! It will be summed up in evdwij and saved in evdw
23565           sigsq     = 1.0D0  / sigsq
23566           sig       = sig0ij * dsqrt(sigsq)
23567 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23568           rij_shift = 1.0/rij - sig + sig0ij
23569           IF (rij_shift.le.0.0D0) THEN
23570            evdw = 1.0D20
23571            RETURN
23572           END IF
23573           sigder = -sig * sigsq
23574           rij_shift = 1.0D0 / rij_shift
23575           fac       = rij_shift**expon
23576           c1        = fac  * fac * aa_scpho(itypi)
23577 !          c1        = 0.0d0
23578           c2        = fac  * bb_scpho(itypi)
23579 !          c2        = 0.0d0
23580           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23581           eps2der   = eps3rt * evdwij
23582           eps3der   = eps2rt * evdwij
23583 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23584           evdwij    = eps2rt * eps3rt * evdwij
23585           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23586           fac    = -expon * (c1 + evdwij) * rij_shift
23587           sigder = fac * sigder
23588 !          fac    = rij * fac
23589 ! Calculate distance derivative
23590           gg(1) =  fac
23591           gg(2) =  fac
23592           gg(3) =  fac
23593           fac = chis1 * sqom1 + chis2 * sqom2 &
23594           - 2.0d0 * chis12 * om1 * om2 * om12
23595 ! we will use pom later in Gcav, so dont mess with it!
23596           pom = 1.0d0 - chis1 * chis2 * sqom12
23597           Lambf = (1.0d0 - (fac / pom))
23598           Lambf = dsqrt(Lambf)
23599           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23600 !       write (*,*) "sparrow = ", sparrow
23601           Chif = 1.0d0/rij * sparrow
23602           ChiLambf = Chif * Lambf
23603           eagle = dsqrt(ChiLambf)
23604           bat = ChiLambf ** 11.0d0
23605           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23606           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23607           botsq = bot * bot
23608           Fcav = top / bot
23609           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23610           dbot = 12.0d0 * b4 * bat * Lambf
23611           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23612 !       dFdR = 0.0d0
23613 !      write (*,*) "dFcav/dR = ", dFdR
23614           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23615           dbot = 12.0d0 * b4 * bat * Chif
23616           eagle = Lambf * pom
23617           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23618           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23619           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23620               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23621
23622           dFdL = ((dtop * bot - top * dbot) / botsq)
23623 !       dFdL = 0.0d0
23624           dCAVdOM1  = dFdL * ( dFdOM1 )
23625           dCAVdOM2  = dFdL * ( dFdOM2 )
23626           dCAVdOM12 = dFdL * ( dFdOM12 )
23627
23628           ertail(1) = xj*rij
23629           ertail(2) = yj*rij
23630           ertail(3) = zj*rij
23631        DO k = 1, 3
23632 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23633 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23634 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
23635
23636         pom = ertail(k)
23637 !        print *,pom,gg(k),dFdR
23638 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23639         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
23640                   - (( dFdR + gg(k) ) * pom)
23641 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23642 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23643 !     &             - ( dFdR * pom )
23644 !        pom = ertail(k)
23645 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23646 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
23647 !                  + (( dFdR + gg(k) ) * pom)
23648 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23649 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23650 !c!     &             + ( dFdR * pom )
23651
23652         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
23653                   - (( dFdR + gg(k) ) * ertail(k))
23654 !c!     &             - ( dFdR * ertail(k))
23655
23656         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
23657                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23658
23659         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
23660                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23661
23662 !c!     &             + ( dFdR * ertail(k))
23663
23664         gg(k) = 0.0d0
23665         ENDDO
23666 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23667 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23668 !      alphapol1 = alphapol_scpho(itypi)
23669        if (wqq_scpho(itypi).ne.0.0) then
23670        Qij=wqq_scpho(itypi)/eps_in
23671        alpha_sco=1.d0/alphi_scpho(itypi)
23672 !       Qij=0.0
23673        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
23674 !c! derivative of Ecl is Gcl...
23675        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
23676                 (Rhead*alpha_sco+1) ) / Rhead_sq
23677        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
23678        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
23679        w1        = wqdip_scpho(1,itypi)
23680        w2        = wqdip_scpho(2,itypi)
23681 !       w1=0.0d0
23682 !       w2=0.0d0
23683 !       pis       = sig0head_scbase(itypi,itypj)
23684 !       eps_head   = epshead_scbase(itypi,itypj)
23685 !c!-------------------------------------------------------------------
23686
23687 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23688 !c!     &        +dhead(1,1,itypi,itypj))**2))
23689 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23690 !c!     &        +dhead(2,1,itypi,itypj))**2))
23691
23692 !c!-------------------------------------------------------------------
23693 !c! ecl
23694        sparrow  = w1  *  om1
23695        hawk     = w2 *  (1.0d0 - sqom2)
23696        Ecl = sparrow / Rhead**2.0d0 &
23697            - hawk    / Rhead**4.0d0
23698 !c!-------------------------------------------------------------------
23699        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
23700            1.0/rij,sparrow
23701
23702 !c! derivative of ecl is Gcl
23703 !c! dF/dr part
23704        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23705                 + 4.0d0 * hawk    / Rhead**5.0d0
23706 !c! dF/dom1
23707        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23708 !c! dF/dom2
23709        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23710        endif
23711
23712 !c--------------------------------------------------------------------
23713 !c Polarization energy
23714 !c Epol
23715        R1 = 0.0d0
23716        DO k = 1, 3
23717 !c! Calculate head-to-tail distances tail is center of side-chain
23718         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
23719        END DO
23720 !c! Pitagoras
23721        R1 = dsqrt(R1)
23722
23723       alphapol1 = alphapol_scpho(itypi)
23724 !      alphapol1=0.0
23725        MomoFac1 = (1.0d0 - chi2 * sqom1)
23726        RR1  = R1 * R1 / MomoFac1
23727        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23728 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
23729        fgb1 = sqrt( RR1 + a12sq * ee1)
23730 !       eps_inout_fac=0.0d0
23731        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23732 ! derivative of Epol is Gpol...
23733        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23734                 / (fgb1 ** 5.0d0)
23735        dFGBdR1 = ( (R1 / MomoFac1) &
23736              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23737              / ( 2.0d0 * fgb1 )
23738        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23739                * (2.0d0 - 0.5d0 * ee1) ) &
23740                / (2.0d0 * fgb1)
23741        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23742 !       dPOLdR1 = 0.0d0
23743 !       dPOLdOM1 = 0.0d0
23744        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
23745                * (2.0d0 - 0.5d0 * ee1) ) &
23746                / (2.0d0 * fgb1)
23747
23748        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
23749        dPOLdOM2 = 0.0
23750        DO k = 1, 3
23751         erhead(k) = Rhead_distance(k)/Rhead
23752         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
23753        END DO
23754
23755        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23756        erdxj = scalar( erhead(1), dC_norm(1,j) )
23757        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23758 !       bat=0.0d0
23759        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
23760        facd1 = d1i * vbld_inv(i+nres)
23761        facd2 = d1j * vbld_inv(j)
23762 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23763
23764        DO k = 1, 3
23765         hawk = (erhead_tail(k,1) + &
23766         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23767 !        facd1=0.0d0
23768 !        facd2=0.0d0
23769 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
23770 !                pom,(erhead_tail(k,1))
23771
23772 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
23773         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23774         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
23775                    - dGCLdR * pom &
23776                    - dPOLdR1 *  (erhead_tail(k,1))
23777 !     &             - dGLJdR * pom
23778
23779         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
23780 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
23781 !                   + dGCLdR * pom  &
23782 !                   + dPOLdR1 * (erhead_tail(k,1))
23783 !     &             + dGLJdR * pom
23784
23785
23786         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
23787                   - dGCLdR * erhead(k) &
23788                   - dPOLdR1 * erhead_tail(k,1)
23789 !     &             - dGLJdR * erhead(k)
23790
23791         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
23792                   + (dGCLdR * erhead(k)  &
23793                   + dPOLdR1 * erhead_tail(k,1))/2.0
23794         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
23795                   + (dGCLdR * erhead(k)  &
23796                   + dPOLdR1 * erhead_tail(k,1))/2.0
23797
23798 !     &             + dGLJdR * erhead(k)
23799 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
23800
23801        END DO
23802 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
23803        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
23804         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
23805        escpho=escpho+evdwij+epol+Fcav+ECL
23806        call sc_grad_scpho
23807          enddo
23808
23809       enddo
23810
23811       return
23812       end subroutine eprot_sc_phosphate
23813       SUBROUTINE sc_grad_scpho
23814       use calc_data
23815
23816        real (kind=8) :: dcosom1(3),dcosom2(3)
23817        eom1  =    &
23818               eps2der * eps2rt_om1   &
23819             - 2.0D0 * alf1 * eps3der &
23820             + sigder * sigsq_om1     &
23821             + dCAVdOM1               &
23822             + dGCLdOM1               &
23823             + dPOLdOM1
23824
23825        eom2  =  &
23826               eps2der * eps2rt_om2   &
23827             + 2.0D0 * alf2 * eps3der &
23828             + sigder * sigsq_om2     &
23829             + dCAVdOM2               &
23830             + dGCLdOM2               &
23831             + dPOLdOM2
23832
23833        eom12 =    &
23834               evdwij  * eps1_om12     &
23835             + eps2der * eps2rt_om12   &
23836             - 2.0D0 * alf12 * eps3der &
23837             + sigder *sigsq_om12      &
23838             + dCAVdOM12               &
23839             + dGCLdOM12
23840 !        om12=0.0
23841 !        eom12=0.0
23842 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23843 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
23844 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23845 !                 *dsci_inv*2.0
23846 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23847 !               gg(1),gg(2),"rozne"
23848        DO k = 1, 3
23849         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23850         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
23851         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23852         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
23853                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
23854                  *dscj_inv*2.0 &
23855                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23856         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
23857                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
23858                  *dscj_inv*2.0 &
23859                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23860         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
23861                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
23862                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23863
23864 !         print *,eom12,eom2,om12,om2
23865 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23866 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23867 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
23868 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23869 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23870         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
23871        END DO
23872        RETURN
23873       END SUBROUTINE sc_grad_scpho
23874       subroutine eprot_pep_phosphate(epeppho)
23875       use calc_data
23876 !      implicit real*8 (a-h,o-z)
23877 !      include 'DIMENSIONS'
23878 !      include 'COMMON.GEO'
23879 !      include 'COMMON.VAR'
23880 !      include 'COMMON.LOCAL'
23881 !      include 'COMMON.CHAIN'
23882 !      include 'COMMON.DERIV'
23883 !      include 'COMMON.NAMES'
23884 !      include 'COMMON.INTERACT'
23885 !      include 'COMMON.IOUNITS'
23886 !      include 'COMMON.CALC'
23887 !      include 'COMMON.CONTROL'
23888 !      include 'COMMON.SBRIDGE'
23889       logical :: lprn
23890 !el local variables
23891       integer :: iint,itypi,itypi1,itypj,subchap
23892       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23893       real(kind=8) :: evdw,sig0ij
23894       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23895                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23896                     sslipi,sslipj,faclip
23897       integer :: ii
23898       real(kind=8) :: fracinbuf
23899        real (kind=8) :: epeppho
23900        real (kind=8),dimension(4):: ener
23901        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23902        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23903         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23904         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23905         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23906         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23907         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23908         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23909        real(kind=8),dimension(3,2)::chead,erhead_tail
23910        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23911        integer troll
23912        real (kind=8) :: dcosom1(3),dcosom2(3)
23913        epeppho=0.0d0
23914 !       do i=1,nres_molec(1)
23915         do i=ibond_start,ibond_end
23916         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23917         itypi  = itype(i,1)
23918         dsci_inv = vbld_inv(i+1)/2.0
23919         dxi    = dc_norm(1,i)
23920         dyi    = dc_norm(2,i)
23921         dzi    = dc_norm(3,i)
23922         xi=(c(1,i)+c(1,i+1))/2.0
23923         yi=(c(2,i)+c(2,i+1))/2.0
23924         zi=(c(3,i)+c(3,i+1))/2.0
23925         xi=mod(xi,boxxsize)
23926          if (xi.lt.0) xi=xi+boxxsize
23927         yi=mod(yi,boxysize)
23928          if (yi.lt.0) yi=yi+boxysize
23929         zi=mod(zi,boxzsize)
23930          if (zi.lt.0) zi=zi+boxzsize
23931          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23932            itypj= itype(j,2)
23933            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23934             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23935            xj=(c(1,j)+c(1,j+1))/2.0
23936            yj=(c(2,j)+c(2,j+1))/2.0
23937            zj=(c(3,j)+c(3,j+1))/2.0
23938            xj=dmod(xj,boxxsize)
23939            if (xj.lt.0) xj=xj+boxxsize
23940            yj=dmod(yj,boxysize)
23941            if (yj.lt.0) yj=yj+boxysize
23942            zj=dmod(zj,boxzsize)
23943            if (zj.lt.0) zj=zj+boxzsize
23944           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23945           xj_safe=xj
23946           yj_safe=yj
23947           zj_safe=zj
23948           subchap=0
23949           do xshift=-1,1
23950           do yshift=-1,1
23951           do zshift=-1,1
23952           xj=xj_safe+xshift*boxxsize
23953           yj=yj_safe+yshift*boxysize
23954           zj=zj_safe+zshift*boxzsize
23955           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23956           if(dist_temp.lt.dist_init) then
23957             dist_init=dist_temp
23958             xj_temp=xj
23959             yj_temp=yj
23960             zj_temp=zj
23961             subchap=1
23962           endif
23963           enddo
23964           enddo
23965           enddo
23966           if (subchap.eq.1) then
23967           xj=xj_temp-xi
23968           yj=yj_temp-yi
23969           zj=zj_temp-zi
23970           else
23971           xj=xj_safe-xi
23972           yj=yj_safe-yi
23973           zj=zj_safe-zi
23974           endif
23975           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23976           rij  = dsqrt(rrij)
23977           dxj = dc_norm( 1,j )
23978           dyj = dc_norm( 2,j )
23979           dzj = dc_norm( 3,j )
23980           dscj_inv = vbld_inv(j+1)/2.0
23981 ! Gay-berne var's
23982           sig0ij = sigma_peppho
23983           chi1=0.0d0
23984           chi2=0.0d0
23985           chi12  = chi1 * chi2
23986           chip1=0.0d0
23987           chip2=0.0d0
23988           chip12 = chip1 * chip2
23989           chis1 = 0.0d0
23990           chis2 = 0.0d0
23991           chis12 = chis1 * chis2
23992           sig1 = sigmap1_peppho
23993           sig2 = sigmap2_peppho
23994 !       write (*,*) "sig1 = ", sig1
23995 !       write (*,*) "sig1 = ", sig1
23996 !       write (*,*) "sig2 = ", sig2
23997 ! alpha factors from Fcav/Gcav
23998           alf1   = 0.0d0
23999           alf2   = 0.0d0
24000           alf12  = 0.0d0
24001           b1 = alphasur_peppho(1)
24002 !          b1=0.0d0
24003           b2 = alphasur_peppho(2)
24004           b3 = alphasur_peppho(3)
24005           b4 = alphasur_peppho(4)
24006           CALL sc_angular
24007        sqom1=om1*om1
24008        evdwij = 0.0d0
24009        ECL = 0.0d0
24010        Elj = 0.0d0
24011        Equad = 0.0d0
24012        Epol = 0.0d0
24013        Fcav=0.0d0
24014        eheadtail = 0.0d0
24015        dGCLdR=0.0d0
24016        dGCLdOM1 = 0.0d0
24017        dGCLdOM2 = 0.0d0
24018        dGCLdOM12 = 0.0d0
24019        dPOLdOM1 = 0.0d0
24020        dPOLdOM2 = 0.0d0
24021           Fcav = 0.0d0
24022           dFdR = 0.0d0
24023           dCAVdOM1  = 0.0d0
24024           dCAVdOM2  = 0.0d0
24025           dCAVdOM12 = 0.0d0
24026           rij_shift = rij
24027           fac       = rij_shift**expon
24028           c1        = fac  * fac * aa_peppho
24029 !          c1        = 0.0d0
24030           c2        = fac  * bb_peppho
24031 !          c2        = 0.0d0
24032           evdwij    =  c1 + c2
24033 ! Now cavity....................
24034        eagle = dsqrt(1.0/rij_shift)
24035        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24036           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24037           botsq = bot * bot
24038           Fcav = top / bot
24039           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24040           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24041           dFdR = ((dtop * bot - top * dbot) / botsq)
24042        w1        = wqdip_peppho(1)
24043        w2        = wqdip_peppho(2)
24044 !       w1=0.0d0
24045 !       w2=0.0d0
24046 !       pis       = sig0head_scbase(itypi,itypj)
24047 !       eps_head   = epshead_scbase(itypi,itypj)
24048 !c!-------------------------------------------------------------------
24049
24050 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24051 !c!     &        +dhead(1,1,itypi,itypj))**2))
24052 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24053 !c!     &        +dhead(2,1,itypi,itypj))**2))
24054
24055 !c!-------------------------------------------------------------------
24056 !c! ecl
24057        sparrow  = w1  *  om1
24058        hawk     = w2 *  (1.0d0 - sqom1)
24059        Ecl = sparrow * rij_shift**2.0d0 &
24060            - hawk    * rij_shift**4.0d0
24061 !c!-------------------------------------------------------------------
24062 !c! derivative of ecl is Gcl
24063 !c! dF/dr part
24064 !       rij_shift=5.0
24065        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24066                 + 4.0d0 * hawk    * rij_shift**5.0d0
24067 !c! dF/dom1
24068        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24069 !c! dF/dom2
24070        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24071        eom1  =    dGCLdOM1+dGCLdOM2
24072        eom2  =    0.0
24073
24074           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24075 !          fac=0.0
24076           gg(1) =  fac*xj*rij
24077           gg(2) =  fac*yj*rij
24078           gg(3) =  fac*zj*rij
24079          do k=1,3
24080          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24081          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24082          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24083          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24084          gg(k)=0.0
24085          enddo
24086
24087       DO k = 1, 3
24088         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24089         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24090         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24091         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24092 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24093         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24094 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24095         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24096                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24097         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24098                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24099         enddo
24100        epeppho=epeppho+evdwij+Fcav+ECL
24101 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24102        enddo
24103        enddo
24104       end subroutine eprot_pep_phosphate
24105       end module energy