source/unres/energy.f90

   1       module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 ! Maximum number of local shielding effectors
  33       integer,parameter :: maxcontsshi=50
  34 !-----------------------------------------------------------------------------
  35 ! commom.calc common/calc/
  36 !-----------------------------------------------------------------------------
  37 ! commom.contacts
  38 !      common /contacts/
  39 ! Change 12/1/95 - common block CONTACTS1 included.
  40 !      common /contacts1/
  41
  42       integer,dimension(:),allocatable :: num_cont      !(maxres)
  43       integer,dimension(:,:),allocatable :: jcont      !(maxconts,maxres)
  44       real(kind=8),dimension(:,:),allocatable :: facont,ees0plist      !(maxconts,maxres)
  45       real(kind=8),dimension(:,:,:),allocatable :: gacont      !(3,maxconts,maxres)
  46       integer,dimension(:),allocatable :: ishield_list
  47       integer,dimension(:,:),allocatable ::  shield_list
  48       real(kind=8),dimension(:),allocatable :: enetube,enecavtube
  49 !
  50 ! 12/26/95 - H-bonding contacts
  51 !      common /contacts_hb/
  52       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  53        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont      !(3,maxconts,maxres)
  54       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  55         ees0m,d_cont      !(maxconts,maxres)
  56       integer,dimension(:),allocatable :: num_cont_hb      !(maxres)
  57       integer,dimension(:,:),allocatable :: jcont_hb      !(maxconts,maxres)
  58 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  59 !         interactions
  60 ! 7/25/08 commented out; not needed when cumulants used
  61 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  62 !  common /dipint/
  63       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  64          dipderg      !(4,maxconts,maxres)
  65       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  66 ! 10/30/99 Added other pre-computed vectors and matrices needed
  67 !          to calculate three - six-order el-loc correlation terms
  68 ! common /rotat/
  69       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der      !(2,2,maxres)
  70       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  71        obrot2_der      !(2,maxres)
  72 !
  73 ! This common block contains vectors and matrices dependent on a single
  74 ! amino-acid residue.
  75 !      common /precomp1/
  76       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  77        Ctobr,Ctobrder,Dtobr2,Dtobr2der      !(2,maxres)
  78       real(kind=8),dimension(:,:,:),allocatable :: EUg,EUgder,CUg,&
  79        CUgder,DUg,Dugder,DtUg2,DtUg2der      !(2,2,maxres)
  80 ! This common block contains vectors and matrices dependent on two
  81 ! consecutive amino-acid residues.
  82 !      common /precomp2/
  83       real(kind=8),dimension(:,:),allocatable :: Ug2Db1t,Ug2Db1tder,&
  84        CUgb2,CUgb2der      !(2,maxres)
  85       real(kind=8),dimension(:,:,:),allocatable :: EUgC,EUgCder,&
  86        EUgD,EUgDder,DtUg2EUg,Ug2DtEUg      !(2,2,maxres)
  87       real(kind=8),dimension(:,:,:,:),allocatable :: Ug2DtEUgder,&
  88        DtUg2EUgder      !(2,2,2,maxres)
  89 !      common /rotat_old/
  90       real(kind=8),dimension(:),allocatable :: costab,sintab,&
  91        costab2,sintab2      !(maxres)
  92 ! This common block contains dipole-interaction matrices and their
  93 ! Cartesian derivatives.
  94 !      common /dipmat/
  95       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj      !(2,2,maxconts,maxres)
  96       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der      !(2,2,3,5,maxconts,maxres)
  97 !      common /diploc/
  98       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  99        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 100       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 101        ADtEA1derg,AEAb2derg
 102       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 103        AECAderx,ADtEAderx,ADtEA1derx
 104       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 105       real(kind=8),dimension(3,2) :: g_contij
 106       real(kind=8) :: ekont
 107 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 108 !   RE: Parallelization of 4th and higher order loc-el correlations
 109 !      common /contdistrib/
 110       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 111 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 112 !-----------------------------------------------------------------------------
 113 ! commom.deriv;
 114 !      common /derivat/
 115 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 116 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 117 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 118       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 119         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 120         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 121         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 122         gliptranx, &
 123         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 124         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 125         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 126         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 127         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 128 !-----------------------------NUCLEIC GRADIENT
 129       real(kind=8),dimension(:,:),allocatable  ::gradb_nucl,gradbx_nucl, &
 130         gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc,gsbloc,&
 131         gsblocx,gradcorr_nucl,gradxorr_nucl,gradcorr3_nucl,gradxorr3_nucl,&
 132         gvdwpp_nucl
 133 !-----------------------------NUCLEIC-PROTEIN GRADIENT
 134       real(kind=8),dimension(:,:),allocatable  :: gvdwx_scbase,gvdwc_scbase,&
 135          gvdwx_pepbase,gvdwc_pepbase,gvdwx_scpho,gvdwc_scpho,&
 136          gvdwc_peppho
 137 !------------------------------IONS GRADIENT
 138         real(kind=8),dimension(:,:),allocatable  ::  gradcatcat, &
 139           gradpepcat,gradpepcatx
 140 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 141
 142
 143       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 144         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 145       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 146         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 147         g_corr6_loc      !(maxvar)
 148       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 149       real(kind=8),dimension(:),allocatable :: gsccor_loc      !(maxres)
 150 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 151       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 152 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 153       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 154          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 155 !      integer :: nfl,icg
 156 !      common /deriv_loc/
 157       real(kind=8), dimension(:),allocatable :: fac_shield
 158       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 159 !      common /deriv_scloc/
 160       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 161        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 162        dZZ_XYZtab      !(3,maxres)
 163 !-----------------------------------------------------------------------------
 164 ! common.maxgrad
 165 !      common /maxgrad/
 166       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 167        gradb_max,ghpbc_max,&
 168        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 169        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 170        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 171        gsccorx_max,gsclocx_max
 172 !-----------------------------------------------------------------------------
 173 ! common.MD
 174 !      common /back_constr/
 175       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 176       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 177 !      common /qmeas/
 178       real(kind=8) :: Ucdfrag,Ucdpair
 179       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 180        dqwol,dxqwol      !(3,0:MAXRES)
 181 !-----------------------------------------------------------------------------
 182 ! common.sbridge
 183 !      common /dyn_ssbond/
 184       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 185 !-----------------------------------------------------------------------------
 186 ! common.sccor
 187 ! Parameters of the SCCOR term
 188 !      common/sccor/
 189       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 190        dcosomicron,domicron      !(3,3,3,maxres2)
 191 !-----------------------------------------------------------------------------
 192 ! common.vectors
 193 !      common /vectors/
 194       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 195       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 196 !-----------------------------------------------------------------------------
 197 ! common /przechowalnia/
 198       real(kind=8),dimension(:,:,:),allocatable :: zapas
 199       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 200       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 201 !-----------------------------------------------------------------------------
 202 !-----------------------------------------------------------------------------
 203 !
 204 !
 205 !-----------------------------------------------------------------------------
 206       contains
 207 !-----------------------------------------------------------------------------
 208 ! energy_p_new_barrier.F
 209 !-----------------------------------------------------------------------------
 210       subroutine etotal(energia)
 211 !      implicit real*8 (a-h,o-z)
 212 !      include 'DIMENSIONS'
 213       use MD_data
 214 #ifndef ISNAN
 215       external proc_proc
 216 #ifdef WINPGI
 217 !MS$ATTRIBUTES C ::  proc_proc
 218 #endif
 219 #endif
 220 #ifdef MPI
 221       include "mpif.h"
 222 #endif
 223 !      include 'COMMON.SETUP'
 224 !      include 'COMMON.IOUNITS'
 225       real(kind=8),dimension(0:n_ene) :: energia
 226 !      include 'COMMON.LOCAL'
 227 !      include 'COMMON.FFIELD'
 228 !      include 'COMMON.DERIV'
 229 !      include 'COMMON.INTERACT'
 230 !      include 'COMMON.SBRIDGE'
 231 !      include 'COMMON.CHAIN'
 232 !      include 'COMMON.VAR'
 233 !      include 'COMMON.MD'
 234 !      include 'COMMON.CONTROL'
 235 !      include 'COMMON.TIME1'
 236       real(kind=8) :: time00
 237 !el local variables
 238       integer :: n_corr,n_corr1,ierror
 239       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 240       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 241       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 242                       Eafmforce,ethetacnstr
 243       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 244 ! now energies for nulceic alone parameters
 245       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 246                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 247                       ecorr3_nucl
 248 ! energies for ions
 249       real(kind=8) :: ecation_prot,ecationcation
 250 ! energies for protein nucleic acid interaction
 251       real(kind=8) :: escbase,epepbase,escpho,epeppho
 252
 253 #ifdef MPI
 254       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 255 ! shielding effect varibles for MPI
 256 !      real(kind=8)   fac_shieldbuf(maxres),
 257 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 258 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 259 !     & grad_shieldbuf(3,-1:maxres)
 260 !       integer ishield_listbuf(maxres),
 261 !     &shield_listbuf(maxcontsshi,maxres)
 262
 263 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 264 !     & " nfgtasks",nfgtasks
 265       if (nfgtasks.gt.1) then
 266         time00=MPI_Wtime()
 267 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 268         if (fg_rank.eq.0) then
 269           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 270 !          print *,"Processor",myrank," BROADCAST iorder"
 271 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 272 ! FG slaves as WEIGHTS array.
 273           weights_(1)=wsc
 274           weights_(2)=wscp
 275           weights_(3)=welec
 276           weights_(4)=wcorr
 277           weights_(5)=wcorr5
 278           weights_(6)=wcorr6
 279           weights_(7)=wel_loc
 280           weights_(8)=wturn3
 281           weights_(9)=wturn4
 282           weights_(10)=wturn6
 283           weights_(11)=wang
 284           weights_(12)=wscloc
 285           weights_(13)=wtor
 286           weights_(14)=wtor_d
 287           weights_(15)=wstrain
 288           weights_(16)=wvdwpp
 289           weights_(17)=wbond
 290           weights_(18)=scal14
 291           weights_(21)=wsccor
 292           weights_(26)=wvdwpp_nucl
 293           weights_(27)=welpp
 294           weights_(28)=wvdwpsb
 295           weights_(29)=welpsb
 296           weights_(30)=wvdwsb
 297           weights_(31)=welsb
 298           weights_(32)=wbond_nucl
 299           weights_(33)=wang_nucl
 300           weights_(34)=wsbloc
 301           weights_(35)=wtor_nucl
 302           weights_(36)=wtor_d_nucl
 303           weights_(37)=wcorr_nucl
 304           weights_(38)=wcorr3_nucl
 305           weights_(41)=wcatcat
 306           weights_(42)=wcatprot
 307           weights_(46)=wscbase
 308           weights_(47)=wscpho
 309           weights_(48)=wpeppho
 310 !          wcatcat= weights(41)
 311 !          wcatprot=weights(42)
 312
 313 ! FG Master broadcasts the WEIGHTS_ array
 314           call MPI_Bcast(weights_(1),n_ene,&
 315              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 316         else
 317 ! FG slaves receive the WEIGHTS array
 318           call MPI_Bcast(weights(1),n_ene,&
 319               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 320           wsc=weights(1)
 321           wscp=weights(2)
 322           welec=weights(3)
 323           wcorr=weights(4)
 324           wcorr5=weights(5)
 325           wcorr6=weights(6)
 326           wel_loc=weights(7)
 327           wturn3=weights(8)
 328           wturn4=weights(9)
 329           wturn6=weights(10)
 330           wang=weights(11)
 331           wscloc=weights(12)
 332           wtor=weights(13)
 333           wtor_d=weights(14)
 334           wstrain=weights(15)
 335           wvdwpp=weights(16)
 336           wbond=weights(17)
 337           scal14=weights(18)
 338           wsccor=weights(21)
 339           wvdwpp_nucl =weights(26)
 340           welpp  =weights(27)
 341           wvdwpsb=weights(28)
 342           welpsb =weights(29)
 343           wvdwsb =weights(30)
 344           welsb  =weights(31)
 345           wbond_nucl  =weights(32)
 346           wang_nucl   =weights(33)
 347           wsbloc =weights(34)
 348           wtor_nucl   =weights(35)
 349           wtor_d_nucl =weights(36)
 350           wcorr_nucl  =weights(37)
 351           wcorr3_nucl =weights(38)
 352           wcatcat= weights(41)
 353           wcatprot=weights(42)
 354           wscbase=weights(46)
 355           wscpho=weights(47)
 356           wpeppho=weights(48)
 357         endif
 358         time_Bcast=time_Bcast+MPI_Wtime()-time00
 359         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 360 !        call chainbuild_cart
 361       endif
 362 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 363 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 364 #else
 365 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 366 !        call int_from_cart1(.false.)
 367 !      endif
 368 #endif
 369 #ifdef TIMING
 370       time00=MPI_Wtime()
 371 #endif
 372 !
 373 ! Compute the side-chain and electrostatic interaction energy
 374 !        print *, "Before EVDW"
 375 !      goto (101,102,103,104,105,106) ipot
 376       select case(ipot)
 377 ! Lennard-Jones potential.
 378 !  101 call elj(evdw)
 379        case (1)
 380          call elj(evdw)
 381 !d    print '(a)','Exit ELJcall el'
 382 !      goto 107
 383 ! Lennard-Jones-Kihara potential (shifted).
 384 !  102 call eljk(evdw)
 385        case (2)
 386          call eljk(evdw)
 387 !      goto 107
 388 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 389 !  103 call ebp(evdw)
 390        case (3)
 391          call ebp(evdw)
 392 !      goto 107
 393 ! Gay-Berne potential (shifted LJ, angular dependence).
 394 !  104 call egb(evdw)
 395        case (4)
 396          call egb(evdw)
 397 !      goto 107
 398 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 399 !  105 call egbv(evdw)
 400        case (5)
 401          call egbv(evdw)
 402 !      goto 107
 403 ! Soft-sphere potential
 404 !  106 call e_softsphere(evdw)
 405        case (6)
 406          call e_softsphere(evdw)
 407 !
 408 ! Calculate electrostatic (H-bonding) energy of the main chain.
 409 !
 410 !  107 continue
 411        case default
 412          write(iout,*)"Wrong ipot"
 413 !         return
 414 !   50 continue
 415       end select
 416 !      continue
 417 !        print *,"after EGB"
 418 ! shielding effect
 419        if (shield_mode.eq.2) then
 420                  call set_shield_fac2
 421        endif
 422 !       print *,"AFTER EGB",ipot,evdw
 423 !mc
 424 !mc Sep-06: egb takes care of dynamic ss bonds too
 425 !mc
 426 !      if (dyn_ss) call dyn_set_nss
 427 !      print *,"Processor",myrank," computed USCSC"
 428 #ifdef TIMING
 429       time01=MPI_Wtime()
 430 #endif
 431       call vec_and_deriv
 432 #ifdef TIMING
 433       time_vec=time_vec+MPI_Wtime()-time01
 434 #endif
 435 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 436       if (ipot.lt.6) then
 437 #ifdef SPLITELE
 438 !         print *,"after ipot if", ipot
 439          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 440              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 441              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 442              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 443 #else
 444          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 445              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 446              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 447              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 448 #endif
 449 !            print *,"just befor eelec call"
 450             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 451 !         write (iout,*) "ELEC calc"
 452          else
 453             ees=0.0d0
 454             evdw1=0.0d0
 455             eel_loc=0.0d0
 456             eello_turn3=0.0d0
 457             eello_turn4=0.0d0
 458          endif
 459       else
 460 !        write (iout,*) "Soft-spheer ELEC potential"
 461         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 462          eello_turn4)
 463       endif
 464 !      print *,"Processor",myrank," computed UELEC"
 465 !
 466 ! Calculate excluded-volume interaction energy between peptide groups
 467 ! and side chains.
 468 !
 469 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 470
 471       if (ipot.lt.6) then
 472        if(wscp.gt.0d0) then
 473         call escp(evdw2,evdw2_14)
 474        else
 475         evdw2=0
 476         evdw2_14=0
 477        endif
 478       else
 479 !        write (iout,*) "Soft-sphere SCP potential"
 480         call escp_soft_sphere(evdw2,evdw2_14)
 481       endif
 482 !       write(iout,*) "in etotal before ebond",ipot
 483
 484 !
 485 ! Calculate the bond-stretching energy
 486 !
 487       call ebond(estr)
 488 !       print *,"EBOND",estr
 489 !       write(iout,*) "in etotal afer ebond",ipot
 490
 491 !
 492 ! Calculate the disulfide-bridge and other energy and the contributions
 493 ! from other distance constraints.
 494 !      print *,'Calling EHPB'
 495       call edis(ehpb)
 496 !elwrite(iout,*) "in etotal afer edis",ipot
 497 !      print *,'EHPB exitted succesfully.'
 498 !
 499 ! Calculate the virtual-bond-angle energy.
 500 !
 501       if (wang.gt.0d0) then
 502         call ebend(ebe,ethetacnstr)
 503       else
 504         ebe=0
 505         ethetacnstr=0
 506       endif
 507 !      print *,"Processor",myrank," computed UB"
 508 !
 509 ! Calculate the SC local energy.
 510 !
 511       call esc(escloc)
 512 !elwrite(iout,*) "in etotal afer esc",ipot
 513 !      print *,"Processor",myrank," computed USC"
 514 !
 515 ! Calculate the virtual-bond torsional energy.
 516 !
 517 !d    print *,'nterm=',nterm
 518       if (wtor.gt.0) then
 519        call etor(etors,edihcnstr)
 520       else
 521        etors=0
 522        edihcnstr=0
 523       endif
 524 !      print *,"Processor",myrank," computed Utor"
 525 !
 526 ! 6/23/01 Calculate double-torsional energy
 527 !
 528 !elwrite(iout,*) "in etotal",ipot
 529       if (wtor_d.gt.0) then
 530        call etor_d(etors_d)
 531       else
 532        etors_d=0
 533       endif
 534 !      print *,"Processor",myrank," computed Utord"
 535 !
 536 ! 21/5/07 Calculate local sicdechain correlation energy
 537 !
 538       if (wsccor.gt.0.0d0) then
 539         call eback_sc_corr(esccor)
 540       else
 541         esccor=0.0d0
 542       endif
 543 !      print *,"Processor",myrank," computed Usccorr"
 544 !
 545 ! 12/1/95 Multi-body terms
 546 !
 547       n_corr=0
 548       n_corr1=0
 549       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 550           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 551          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 552 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 553 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 554       else
 555          ecorr=0.0d0
 556          ecorr5=0.0d0
 557          ecorr6=0.0d0
 558          eturn6=0.0d0
 559       endif
 560 !elwrite(iout,*) "in etotal",ipot
 561       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 562          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 563 !d         write (iout,*) "multibody_hb ecorr",ecorr
 564       endif
 565 !elwrite(iout,*) "afeter  multibody hb"
 566
 567 !      print *,"Processor",myrank," computed Ucorr"
 568 !
 569 ! If performing constraint dynamics, call the constraint energy
 570 !  after the equilibration time
 571       if(usampl.and.totT.gt.eq_time) then
 572 !elwrite(iout,*) "afeter  multibody hb"
 573          call EconstrQ
 574 !elwrite(iout,*) "afeter  multibody hb"
 575          call Econstr_back
 576 !elwrite(iout,*) "afeter  multibody hb"
 577       else
 578          Uconst=0.0d0
 579          Uconst_back=0.0d0
 580       endif
 581       call flush(iout)
 582 !         write(iout,*) "after Econstr"
 583
 584       if (wliptran.gt.0) then
 585 !        print *,"PRZED WYWOLANIEM"
 586         call Eliptransfer(eliptran)
 587       else
 588        eliptran=0.0d0
 589       endif
 590       if (fg_rank.eq.0) then
 591       if (AFMlog.gt.0) then
 592         call AFMforce(Eafmforce)
 593       else if (selfguide.gt.0) then
 594         call AFMvel(Eafmforce)
 595       endif
 596       endif
 597       if (tubemode.eq.1) then
 598        call calctube(etube)
 599       else if (tubemode.eq.2) then
 600        call calctube2(etube)
 601       elseif (tubemode.eq.3) then
 602        call calcnano(etube)
 603       else
 604        etube=0.0d0
 605       endif
 606 !--------------------------------------------------------
 607 !      print *,"before",ees,evdw1,ecorr
 608       if (nres_molec(2).gt.0) then
 609       call ebond_nucl(estr_nucl)
 610       call ebend_nucl(ebe_nucl)
 611       call etor_nucl(etors_nucl)
 612       call esb_gb(evdwsb,eelsb)
 613       call epp_nucl_sub(evdwpp,eespp)
 614       call epsb(evdwpsb,eelpsb)
 615       call esb(esbloc)
 616       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 617       endif
 618       if (nfgtasks.gt.1) then
 619       if (fg_rank.eq.0) then
 620       call ecatcat(ecationcation)
 621       endif
 622       else
 623       call ecatcat(ecationcation)
 624       endif
 625       call ecat_prot(ecation_prot)
 626       if (nres_molec(2).gt.0) then
 627       call eprot_sc_base(escbase)
 628       call epep_sc_base(epepbase)
 629       call eprot_sc_phosphate(escpho)
 630       call eprot_pep_phosphate(epeppho)
 631       endif
 632 !      call ecatcat(ecationcation)
 633 !      print *,"after ebend", ebe_nucl
 634 #ifdef TIMING
 635       time_enecalc=time_enecalc+MPI_Wtime()-time00
 636 #endif
 637 !      print *,"Processor",myrank," computed Uconstr"
 638 #ifdef TIMING
 639       time00=MPI_Wtime()
 640 #endif
 641 !
 642 ! Sum the energies
 643 !
 644       energia(1)=evdw
 645 #ifdef SCP14
 646       energia(2)=evdw2-evdw2_14
 647       energia(18)=evdw2_14
 648 #else
 649       energia(2)=evdw2
 650       energia(18)=0.0d0
 651 #endif
 652 #ifdef SPLITELE
 653       energia(3)=ees
 654       energia(16)=evdw1
 655 #else
 656       energia(3)=ees+evdw1
 657       energia(16)=0.0d0
 658 #endif
 659       energia(4)=ecorr
 660       energia(5)=ecorr5
 661       energia(6)=ecorr6
 662       energia(7)=eel_loc
 663       energia(8)=eello_turn3
 664       energia(9)=eello_turn4
 665       energia(10)=eturn6
 666       energia(11)=ebe
 667       energia(12)=escloc
 668       energia(13)=etors
 669       energia(14)=etors_d
 670       energia(15)=ehpb
 671       energia(19)=edihcnstr
 672       energia(17)=estr
 673       energia(20)=Uconst+Uconst_back
 674       energia(21)=esccor
 675       energia(22)=eliptran
 676       energia(23)=Eafmforce
 677       energia(24)=ethetacnstr
 678       energia(25)=etube
 679 !---------------------------------------------------------------
 680       energia(26)=evdwpp
 681       energia(27)=eespp
 682       energia(28)=evdwpsb
 683       energia(29)=eelpsb
 684       energia(30)=evdwsb
 685       energia(31)=eelsb
 686       energia(32)=estr_nucl
 687       energia(33)=ebe_nucl
 688       energia(34)=esbloc
 689       energia(35)=etors_nucl
 690       energia(36)=etors_d_nucl
 691       energia(37)=ecorr_nucl
 692       energia(38)=ecorr3_nucl
 693 !----------------------------------------------------------------------
 694 !    Here are the energies showed per procesor if the are more processors
 695 !    per molecule then we sum it up in sum_energy subroutine
 696 !      print *," Processor",myrank," calls SUM_ENERGY"
 697       energia(41)=ecation_prot
 698       energia(42)=ecationcation
 699       energia(46)=escbase
 700       energia(47)=epepbase
 701       energia(48)=escpho
 702       energia(49)=epeppho
 703       call sum_energy(energia,.true.)
 704       if (dyn_ss) call dyn_set_nss
 705 !      print *," Processor",myrank," left SUM_ENERGY"
 706 #ifdef TIMING
 707       time_sumene=time_sumene+MPI_Wtime()-time00
 708 #endif
 709 !el        call enerprint(energia)
 710 !elwrite(iout,*)"finish etotal"
 711       return
 712       end subroutine etotal
 713 !-----------------------------------------------------------------------------
 714       subroutine sum_energy(energia,reduce)
 715 !      implicit real*8 (a-h,o-z)
 716 !      include 'DIMENSIONS'
 717 #ifndef ISNAN
 718       external proc_proc
 719 #ifdef WINPGI
 720 !MS$ATTRIBUTES C ::  proc_proc
 721 #endif
 722 #endif
 723 #ifdef MPI
 724       include "mpif.h"
 725 #endif
 726 !      include 'COMMON.SETUP'
 727 !      include 'COMMON.IOUNITS'
 728       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 729 !      include 'COMMON.FFIELD'
 730 !      include 'COMMON.DERIV'
 731 !      include 'COMMON.INTERACT'
 732 !      include 'COMMON.SBRIDGE'
 733 !      include 'COMMON.CHAIN'
 734 !      include 'COMMON.VAR'
 735 !      include 'COMMON.CONTROL'
 736 !      include 'COMMON.TIME1'
 737       logical :: reduce
 738       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 739       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 740       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 741         eliptran,etube, Eafmforce,ethetacnstr
 742       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 743                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 744                       ecorr3_nucl
 745       real(kind=8) :: ecation_prot,ecationcation
 746       real(kind=8) :: escbase,epepbase,escpho,epeppho
 747       integer :: i
 748 #ifdef MPI
 749       integer :: ierr
 750       real(kind=8) :: time00
 751       if (nfgtasks.gt.1 .and. reduce) then
 752
 753 #ifdef DEBUG
 754         write (iout,*) "energies before REDUCE"
 755         call enerprint(energia)
 756         call flush(iout)
 757 #endif
 758         do i=0,n_ene
 759           enebuff(i)=energia(i)
 760         enddo
 761         time00=MPI_Wtime()
 762         call MPI_Barrier(FG_COMM,IERR)
 763         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 764         time00=MPI_Wtime()
 765         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 766           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 767 #ifdef DEBUG
 768         write (iout,*) "energies after REDUCE"
 769         call enerprint(energia)
 770         call flush(iout)
 771 #endif
 772         time_Reduce=time_Reduce+MPI_Wtime()-time00
 773       endif
 774       if (fg_rank.eq.0) then
 775 #endif
 776       evdw=energia(1)
 777 #ifdef SCP14
 778       evdw2=energia(2)+energia(18)
 779       evdw2_14=energia(18)
 780 #else
 781       evdw2=energia(2)
 782 #endif
 783 #ifdef SPLITELE
 784       ees=energia(3)
 785       evdw1=energia(16)
 786 #else
 787       ees=energia(3)
 788       evdw1=0.0d0
 789 #endif
 790       ecorr=energia(4)
 791       ecorr5=energia(5)
 792       ecorr6=energia(6)
 793       eel_loc=energia(7)
 794       eello_turn3=energia(8)
 795       eello_turn4=energia(9)
 796       eturn6=energia(10)
 797       ebe=energia(11)
 798       escloc=energia(12)
 799       etors=energia(13)
 800       etors_d=energia(14)
 801       ehpb=energia(15)
 802       edihcnstr=energia(19)
 803       estr=energia(17)
 804       Uconst=energia(20)
 805       esccor=energia(21)
 806       eliptran=energia(22)
 807       Eafmforce=energia(23)
 808       ethetacnstr=energia(24)
 809       etube=energia(25)
 810       evdwpp=energia(26)
 811       eespp=energia(27)
 812       evdwpsb=energia(28)
 813       eelpsb=energia(29)
 814       evdwsb=energia(30)
 815       eelsb=energia(31)
 816       estr_nucl=energia(32)
 817       ebe_nucl=energia(33)
 818       esbloc=energia(34)
 819       etors_nucl=energia(35)
 820       etors_d_nucl=energia(36)
 821       ecorr_nucl=energia(37)
 822       ecorr3_nucl=energia(38)
 823       ecation_prot=energia(41)
 824       ecationcation=energia(42)
 825       escbase=energia(46)
 826       epepbase=energia(47)
 827       escpho=energia(48)
 828       epeppho=energia(49)
 829 !      energia(41)=ecation_prot
 830 !      energia(42)=ecationcation
 831
 832
 833 #ifdef SPLITELE
 834       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 835        +wang*ebe+wtor*etors+wscloc*escloc &
 836        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 837        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 838        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 839        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 840        +Eafmforce+ethetacnstr  &
 841        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 842        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 843        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 844        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 845        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 846        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 847 #else
 848       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 849        +wang*ebe+wtor*etors+wscloc*escloc &
 850        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 851        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 852        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 853        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 854        +Eafmforce+ethetacnstr &
 855        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 856        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 857        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 858        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 859        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 860        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 861 #endif
 862       energia(0)=etot
 863 ! detecting NaNQ
 864 #ifdef ISNAN
 865 #ifdef AIX
 866       if (isnan(etot).ne.0) energia(0)=1.0d+99
 867 #else
 868       if (isnan(etot)) energia(0)=1.0d+99
 869 #endif
 870 #else
 871       i=0
 872 #ifdef WINPGI
 873       idumm=proc_proc(etot,i)
 874 #else
 875       call proc_proc(etot,i)
 876 #endif
 877       if(i.eq.1)energia(0)=1.0d+99
 878 #endif
 879 #ifdef MPI
 880       endif
 881 #endif
 882 !      call enerprint(energia)
 883       call flush(iout)
 884       return
 885       end subroutine sum_energy
 886 !-----------------------------------------------------------------------------
 887       subroutine rescale_weights(t_bath)
 888 !      implicit real*8 (a-h,o-z)
 889 #ifdef MPI
 890       include 'mpif.h'
 891 #endif
 892 !      include 'DIMENSIONS'
 893 !      include 'COMMON.IOUNITS'
 894 !      include 'COMMON.FFIELD'
 895 !      include 'COMMON.SBRIDGE'
 896       real(kind=8) :: kfac=2.4d0
 897       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 898 !el local variables
 899       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 900       real(kind=8) :: T0=3.0d2
 901       integer :: ierror
 902 !      facT=temp0/t_bath
 903 !      facT=2*temp0/(t_bath+temp0)
 904       if (rescale_mode.eq.0) then
 905         facT(1)=1.0d0
 906         facT(2)=1.0d0
 907         facT(3)=1.0d0
 908         facT(4)=1.0d0
 909         facT(5)=1.0d0
 910         facT(6)=1.0d0
 911       else if (rescale_mode.eq.1) then
 912         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 913         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 914         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 915         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 916         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 917 #ifdef WHAM_RUN
 918 !#if defined(WHAM_RUN) || defined(CLUSTER)
 919 #if defined(FUNCTH)
 920 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 921         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 922 #elif defined(FUNCT)
 923         facT(6)=t_bath/T0
 924 #else
 925         facT(6)=1.0d0
 926 #endif
 927 #endif
 928       else if (rescale_mode.eq.2) then
 929         x=t_bath/temp0
 930         x2=x*x
 931         x3=x2*x
 932         x4=x3*x
 933         x5=x4*x
 934         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 935         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 936         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 937         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 938         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 939 #ifdef WHAM_RUN
 940 !#if defined(WHAM_RUN) || defined(CLUSTER)
 941 #if defined(FUNCTH)
 942         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 943 #elif defined(FUNCT)
 944         facT(6)=t_bath/T0
 945 #else
 946         facT(6)=1.0d0
 947 #endif
 948 #endif
 949       else
 950         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 951         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 952 #ifdef MPI
 953        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 954 #endif
 955        stop 555
 956       endif
 957       welec=weights(3)*fact(1)
 958       wcorr=weights(4)*fact(3)
 959       wcorr5=weights(5)*fact(4)
 960       wcorr6=weights(6)*fact(5)
 961       wel_loc=weights(7)*fact(2)
 962       wturn3=weights(8)*fact(2)
 963       wturn4=weights(9)*fact(3)
 964       wturn6=weights(10)*fact(5)
 965       wtor=weights(13)*fact(1)
 966       wtor_d=weights(14)*fact(2)
 967       wsccor=weights(21)*fact(1)
 968
 969       return
 970       end subroutine rescale_weights
 971 !-----------------------------------------------------------------------------
 972       subroutine enerprint(energia)
 973 !      implicit real*8 (a-h,o-z)
 974 !      include 'DIMENSIONS'
 975 !      include 'COMMON.IOUNITS'
 976 !      include 'COMMON.FFIELD'
 977 !      include 'COMMON.SBRIDGE'
 978 !      include 'COMMON.MD'
 979       real(kind=8) :: energia(0:n_ene)
 980 !el local variables
 981       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 982       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 983       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 984        etube,ethetacnstr,Eafmforce
 985       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 986                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 987                       ecorr3_nucl
 988       real(kind=8) :: ecation_prot,ecationcation
 989       real(kind=8) :: escbase,epepbase,escpho,epeppho
 990
 991       etot=energia(0)
 992       evdw=energia(1)
 993       evdw2=energia(2)
 994 #ifdef SCP14
 995       evdw2=energia(2)+energia(18)
 996 #else
 997       evdw2=energia(2)
 998 #endif
 999       ees=energia(3)
1000 #ifdef SPLITELE
1001       evdw1=energia(16)
1002 #endif
1003       ecorr=energia(4)
1004       ecorr5=energia(5)
1005       ecorr6=energia(6)
1006       eel_loc=energia(7)
1007       eello_turn3=energia(8)
1008       eello_turn4=energia(9)
1009       eello_turn6=energia(10)
1010       ebe=energia(11)
1011       escloc=energia(12)
1012       etors=energia(13)
1013       etors_d=energia(14)
1014       ehpb=energia(15)
1015       edihcnstr=energia(19)
1016       estr=energia(17)
1017       Uconst=energia(20)
1018       esccor=energia(21)
1019       eliptran=energia(22)
1020       Eafmforce=energia(23)
1021       ethetacnstr=energia(24)
1022       etube=energia(25)
1023       evdwpp=energia(26)
1024       eespp=energia(27)
1025       evdwpsb=energia(28)
1026       eelpsb=energia(29)
1027       evdwsb=energia(30)
1028       eelsb=energia(31)
1029       estr_nucl=energia(32)
1030       ebe_nucl=energia(33)
1031       esbloc=energia(34)
1032       etors_nucl=energia(35)
1033       etors_d_nucl=energia(36)
1034       ecorr_nucl=energia(37)
1035       ecorr3_nucl=energia(38)
1036       ecation_prot=energia(41)
1037       ecationcation=energia(42)
1038       escbase=energia(46)
1039       epepbase=energia(47)
1040       escpho=energia(48)
1041       epeppho=energia(49)
1042 #ifdef SPLITELE
1043       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1044         estr,wbond,ebe,wang,&
1045         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1046         ecorr,wcorr,&
1047         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1048         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1049         edihcnstr,ethetacnstr,ebr*nss,&
1050         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1051         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1052         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1053         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1054         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1055         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1056         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1057         etot
1058    10 format (/'Virtual-chain energies:'// &
1059        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1060        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1061        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1062        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1063        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1064        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1065        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1066        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1067        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1068        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1069        ' (SS bridges & dist. cnstr.)'/ &
1070        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1071        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1072        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1073        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1074        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1075        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1076        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1077        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1078        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1079        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1080        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1081        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1082        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1083        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1084        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1085        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1086        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1087        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1088        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1089        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1090        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1091        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1092        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1093        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1094        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1095        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1096        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1097        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1098        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1099        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1100        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1101        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1102        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1103        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1104        'ETOT=  ',1pE16.6,' (total)')
1105 #else
1106       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1107         estr,wbond,ebe,wang,&
1108         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1109         ecorr,wcorr,&
1110         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1111         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1112         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1113         etube,wtube, &
1114         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1115         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1116         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1117         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1118         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1119         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1120         etot
1121    10 format (/'Virtual-chain energies:'// &
1122        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1123        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1124        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1125        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1126        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1127        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1128        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1129        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1130        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1131        ' (SS bridges & dist. cnstr.)'/ &
1132        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1133        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1134        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1135        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1136        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1137        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1138        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1139        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1140        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1141        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1142        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1143        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1144        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1145        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1146        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1147        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1148        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1149        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1150        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1151        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1152        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1153        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1154        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1155        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1156        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1157        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1158        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1159        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1160        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1161        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1162        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1163        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1164        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1165        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1166        'ETOT=  ',1pE16.6,' (total)')
1167 #endif
1168       return
1169       end subroutine enerprint
1170 !-----------------------------------------------------------------------------
1171       subroutine elj(evdw)
1172 !
1173 ! This subroutine calculates the interaction energy of nonbonded side chains
1174 ! assuming the LJ potential of interaction.
1175 !
1176 !      implicit real*8 (a-h,o-z)
1177 !      include 'DIMENSIONS'
1178       real(kind=8),parameter :: accur=1.0d-10
1179 !      include 'COMMON.GEO'
1180 !      include 'COMMON.VAR'
1181 !      include 'COMMON.LOCAL'
1182 !      include 'COMMON.CHAIN'
1183 !      include 'COMMON.DERIV'
1184 !      include 'COMMON.INTERACT'
1185 !      include 'COMMON.TORSION'
1186 !      include 'COMMON.SBRIDGE'
1187 !      include 'COMMON.NAMES'
1188 !      include 'COMMON.IOUNITS'
1189 !      include 'COMMON.CONTACTS'
1190       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1191       integer :: num_conti
1192 !el local variables
1193       integer :: i,itypi,iint,j,itypi1,itypj,k
1194       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1195       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1196       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1197
1198 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1199       evdw=0.0D0
1200 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1201 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1202 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1203 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1204
1205       do i=iatsc_s,iatsc_e
1206         itypi=iabs(itype(i,1))
1207         if (itypi.eq.ntyp1) cycle
1208         itypi1=iabs(itype(i+1,1))
1209         xi=c(1,nres+i)
1210         yi=c(2,nres+i)
1211         zi=c(3,nres+i)
1212 ! Change 12/1/95
1213         num_conti=0
1214 !
1215 ! Calculate SC interaction energy.
1216 !
1217         do iint=1,nint_gr(i)
1218 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1219 !d   &                  'iend=',iend(i,iint)
1220           do j=istart(i,iint),iend(i,iint)
1221             itypj=iabs(itype(j,1))
1222             if (itypj.eq.ntyp1) cycle
1223             xj=c(1,nres+j)-xi
1224             yj=c(2,nres+j)-yi
1225             zj=c(3,nres+j)-zi
1226 ! Change 12/1/95 to calculate four-body interactions
1227             rij=xj*xj+yj*yj+zj*zj
1228             rrij=1.0D0/rij
1229 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1230             eps0ij=eps(itypi,itypj)
1231             fac=rrij**expon2
1232             e1=fac*fac*aa_aq(itypi,itypj)
1233             e2=fac*bb_aq(itypi,itypj)
1234             evdwij=e1+e2
1235 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1236 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1237 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1238 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1239 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1240 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1241             evdw=evdw+evdwij
1242 !
1243 ! Calculate the components of the gradient in DC and X
1244 !
1245             fac=-rrij*(e1+evdwij)
1246             gg(1)=xj*fac
1247             gg(2)=yj*fac
1248             gg(3)=zj*fac
1249             do k=1,3
1250               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1251               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1252               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1253               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1254             enddo
1255 !grad            do k=i,j-1
1256 !grad              do l=1,3
1257 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1258 !grad              enddo
1259 !grad            enddo
1260 !
1261 ! 12/1/95, revised on 5/20/97
1262 !
1263 ! Calculate the contact function. The ith column of the array JCONT will
1264 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1265 ! greater than I). The arrays FACONT and GACONT will contain the values of
1266 ! the contact function and its derivative.
1267 !
1268 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1269 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1270 ! Uncomment next line, if the correlation interactions are contact function only
1271             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1272               rij=dsqrt(rij)
1273               sigij=sigma(itypi,itypj)
1274               r0ij=rs0(itypi,itypj)
1275 !
1276 ! Check whether the SC's are not too far to make a contact.
1277 !
1278               rcut=1.5d0*r0ij
1279               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1280 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1281 !
1282               if (fcont.gt.0.0D0) then
1283 ! If the SC-SC distance if close to sigma, apply spline.
1284 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1285 !Adam &             fcont1,fprimcont1)
1286 !Adam           fcont1=1.0d0-fcont1
1287 !Adam           if (fcont1.gt.0.0d0) then
1288 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1289 !Adam             fcont=fcont*fcont1
1290 !Adam           endif
1291 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1292 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1293 !ga             do k=1,3
1294 !ga               gg(k)=gg(k)*eps0ij
1295 !ga             enddo
1296 !ga             eps0ij=-evdwij*eps0ij
1297 ! Uncomment for AL's type of SC correlation interactions.
1298 !adam           eps0ij=-evdwij
1299                 num_conti=num_conti+1
1300                 jcont(num_conti,i)=j
1301                 facont(num_conti,i)=fcont*eps0ij
1302                 fprimcont=eps0ij*fprimcont/rij
1303                 fcont=expon*fcont
1304 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1305 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1306 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1307 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1308                 gacont(1,num_conti,i)=-fprimcont*xj
1309                 gacont(2,num_conti,i)=-fprimcont*yj
1310                 gacont(3,num_conti,i)=-fprimcont*zj
1311 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1312 !d              write (iout,'(2i3,3f10.5)')
1313 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1314               endif
1315             endif
1316           enddo      ! j
1317         enddo        ! iint
1318 ! Change 12/1/95
1319         num_cont(i)=num_conti
1320       enddo          ! i
1321       do i=1,nct
1322         do j=1,3
1323           gvdwc(j,i)=expon*gvdwc(j,i)
1324           gvdwx(j,i)=expon*gvdwx(j,i)
1325         enddo
1326       enddo
1327 !******************************************************************************
1328 !
1329 !                              N O T E !!!
1330 !
1331 ! To save time, the factor of EXPON has been extracted from ALL components
1332 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1333 ! use!
1334 !
1335 !******************************************************************************
1336       return
1337       end subroutine elj
1338 !-----------------------------------------------------------------------------
1339       subroutine eljk(evdw)
1340 !
1341 ! This subroutine calculates the interaction energy of nonbonded side chains
1342 ! assuming the LJK potential of interaction.
1343 !
1344 !      implicit real*8 (a-h,o-z)
1345 !      include 'DIMENSIONS'
1346 !      include 'COMMON.GEO'
1347 !      include 'COMMON.VAR'
1348 !      include 'COMMON.LOCAL'
1349 !      include 'COMMON.CHAIN'
1350 !      include 'COMMON.DERIV'
1351 !      include 'COMMON.INTERACT'
1352 !      include 'COMMON.IOUNITS'
1353 !      include 'COMMON.NAMES'
1354       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1355       logical :: scheck
1356 !el local variables
1357       integer :: i,iint,j,itypi,itypi1,k,itypj
1358       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1359       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1360
1361 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1362       evdw=0.0D0
1363       do i=iatsc_s,iatsc_e
1364         itypi=iabs(itype(i,1))
1365         if (itypi.eq.ntyp1) cycle
1366         itypi1=iabs(itype(i+1,1))
1367         xi=c(1,nres+i)
1368         yi=c(2,nres+i)
1369         zi=c(3,nres+i)
1370 !
1371 ! Calculate SC interaction energy.
1372 !
1373         do iint=1,nint_gr(i)
1374           do j=istart(i,iint),iend(i,iint)
1375             itypj=iabs(itype(j,1))
1376             if (itypj.eq.ntyp1) cycle
1377             xj=c(1,nres+j)-xi
1378             yj=c(2,nres+j)-yi
1379             zj=c(3,nres+j)-zi
1380             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1381             fac_augm=rrij**expon
1382             e_augm=augm(itypi,itypj)*fac_augm
1383             r_inv_ij=dsqrt(rrij)
1384             rij=1.0D0/r_inv_ij
1385             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1386             fac=r_shift_inv**expon
1387             e1=fac*fac*aa_aq(itypi,itypj)
1388             e2=fac*bb_aq(itypi,itypj)
1389             evdwij=e_augm+e1+e2
1390 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1391 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1392 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1393 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1394 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1395 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1396 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1397             evdw=evdw+evdwij
1398 !
1399 ! Calculate the components of the gradient in DC and X
1400 !
1401             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1402             gg(1)=xj*fac
1403             gg(2)=yj*fac
1404             gg(3)=zj*fac
1405             do k=1,3
1406               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1407               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1408               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1409               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1410             enddo
1411 !grad            do k=i,j-1
1412 !grad              do l=1,3
1413 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1414 !grad              enddo
1415 !grad            enddo
1416           enddo      ! j
1417         enddo        ! iint
1418       enddo          ! i
1419       do i=1,nct
1420         do j=1,3
1421           gvdwc(j,i)=expon*gvdwc(j,i)
1422           gvdwx(j,i)=expon*gvdwx(j,i)
1423         enddo
1424       enddo
1425       return
1426       end subroutine eljk
1427 !-----------------------------------------------------------------------------
1428       subroutine ebp(evdw)
1429 !
1430 ! This subroutine calculates the interaction energy of nonbonded side chains
1431 ! assuming the Berne-Pechukas potential of interaction.
1432 !
1433       use comm_srutu
1434       use calc_data
1435 !      implicit real*8 (a-h,o-z)
1436 !      include 'DIMENSIONS'
1437 !      include 'COMMON.GEO'
1438 !      include 'COMMON.VAR'
1439 !      include 'COMMON.LOCAL'
1440 !      include 'COMMON.CHAIN'
1441 !      include 'COMMON.DERIV'
1442 !      include 'COMMON.NAMES'
1443 !      include 'COMMON.INTERACT'
1444 !      include 'COMMON.IOUNITS'
1445 !      include 'COMMON.CALC'
1446       use comm_srutu
1447 !el      integer :: icall
1448 !el      common /srutu/ icall
1449 !     double precision rrsave(maxdim)
1450       logical :: lprn
1451 !el local variables
1452       integer :: iint,itypi,itypi1,itypj
1453       real(kind=8) :: rrij,xi,yi,zi
1454       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1455
1456 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1457       evdw=0.0D0
1458 !     if (icall.eq.0) then
1459 !       lprn=.true.
1460 !     else
1461         lprn=.false.
1462 !     endif
1463 !el      ind=0
1464       do i=iatsc_s,iatsc_e
1465         itypi=iabs(itype(i,1))
1466         if (itypi.eq.ntyp1) cycle
1467         itypi1=iabs(itype(i+1,1))
1468         xi=c(1,nres+i)
1469         yi=c(2,nres+i)
1470         zi=c(3,nres+i)
1471         dxi=dc_norm(1,nres+i)
1472         dyi=dc_norm(2,nres+i)
1473         dzi=dc_norm(3,nres+i)
1474 !        dsci_inv=dsc_inv(itypi)
1475         dsci_inv=vbld_inv(i+nres)
1476 !
1477 ! Calculate SC interaction energy.
1478 !
1479         do iint=1,nint_gr(i)
1480           do j=istart(i,iint),iend(i,iint)
1481 !el            ind=ind+1
1482             itypj=iabs(itype(j,1))
1483             if (itypj.eq.ntyp1) cycle
1484 !            dscj_inv=dsc_inv(itypj)
1485             dscj_inv=vbld_inv(j+nres)
1486             chi1=chi(itypi,itypj)
1487             chi2=chi(itypj,itypi)
1488             chi12=chi1*chi2
1489             chip1=chip(itypi)
1490             chip2=chip(itypj)
1491             chip12=chip1*chip2
1492             alf1=alp(itypi)
1493             alf2=alp(itypj)
1494             alf12=0.5D0*(alf1+alf2)
1495 ! For diagnostics only!!!
1496 !           chi1=0.0D0
1497 !           chi2=0.0D0
1498 !           chi12=0.0D0
1499 !           chip1=0.0D0
1500 !           chip2=0.0D0
1501 !           chip12=0.0D0
1502 !           alf1=0.0D0
1503 !           alf2=0.0D0
1504 !           alf12=0.0D0
1505             xj=c(1,nres+j)-xi
1506             yj=c(2,nres+j)-yi
1507             zj=c(3,nres+j)-zi
1508             dxj=dc_norm(1,nres+j)
1509             dyj=dc_norm(2,nres+j)
1510             dzj=dc_norm(3,nres+j)
1511             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1512 !d          if (icall.eq.0) then
1513 !d            rrsave(ind)=rrij
1514 !d          else
1515 !d            rrij=rrsave(ind)
1516 !d          endif
1517             rij=dsqrt(rrij)
1518 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1519             call sc_angular
1520 ! Calculate whole angle-dependent part of epsilon and contributions
1521 ! to its derivatives
1522             fac=(rrij*sigsq)**expon2
1523             e1=fac*fac*aa_aq(itypi,itypj)
1524             e2=fac*bb_aq(itypi,itypj)
1525             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1526             eps2der=evdwij*eps3rt
1527             eps3der=evdwij*eps2rt
1528             evdwij=evdwij*eps2rt*eps3rt
1529             evdw=evdw+evdwij
1530             if (lprn) then
1531             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1532             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1533 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1534 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1535 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1536 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1537 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1538 !d     &        evdwij
1539             endif
1540 ! Calculate gradient components.
1541             e1=e1*eps1*eps2rt**2*eps3rt**2
1542             fac=-expon*(e1+evdwij)
1543             sigder=fac/sigsq
1544             fac=rrij*fac
1545 ! Calculate radial part of the gradient
1546             gg(1)=xj*fac
1547             gg(2)=yj*fac
1548             gg(3)=zj*fac
1549 ! Calculate the angular part of the gradient and sum add the contributions
1550 ! to the appropriate components of the Cartesian gradient.
1551             call sc_grad
1552           enddo      ! j
1553         enddo        ! iint
1554       enddo          ! i
1555 !     stop
1556       return
1557       end subroutine ebp
1558 !-----------------------------------------------------------------------------
1559       subroutine egb(evdw)
1560 !
1561 ! This subroutine calculates the interaction energy of nonbonded side chains
1562 ! assuming the Gay-Berne potential of interaction.
1563 !
1564       use calc_data
1565 !      implicit real*8 (a-h,o-z)
1566 !      include 'DIMENSIONS'
1567 !      include 'COMMON.GEO'
1568 !      include 'COMMON.VAR'
1569 !      include 'COMMON.LOCAL'
1570 !      include 'COMMON.CHAIN'
1571 !      include 'COMMON.DERIV'
1572 !      include 'COMMON.NAMES'
1573 !      include 'COMMON.INTERACT'
1574 !      include 'COMMON.IOUNITS'
1575 !      include 'COMMON.CALC'
1576 !      include 'COMMON.CONTROL'
1577 !      include 'COMMON.SBRIDGE'
1578       logical :: lprn
1579 !el local variables
1580       integer :: iint,itypi,itypi1,itypj,subchap
1581       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1582       real(kind=8) :: evdw,sig0ij
1583       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1584                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1585                     sslipi,sslipj,faclip
1586       integer :: ii
1587       real(kind=8) :: fracinbuf
1588
1589 !cccc      energy_dec=.false.
1590 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1591       evdw=0.0D0
1592       lprn=.false.
1593 !     if (icall.eq.0) lprn=.false.
1594 !el      ind=0
1595       do i=iatsc_s,iatsc_e
1596 !C        print *,"I am in EVDW",i
1597         itypi=iabs(itype(i,1))
1598 !        if (i.ne.47) cycle
1599         if (itypi.eq.ntyp1) cycle
1600         itypi1=iabs(itype(i+1,1))
1601         xi=c(1,nres+i)
1602         yi=c(2,nres+i)
1603         zi=c(3,nres+i)
1604           xi=dmod(xi,boxxsize)
1605           if (xi.lt.0) xi=xi+boxxsize
1606           yi=dmod(yi,boxysize)
1607           if (yi.lt.0) yi=yi+boxysize
1608           zi=dmod(zi,boxzsize)
1609           if (zi.lt.0) zi=zi+boxzsize
1610
1611        if ((zi.gt.bordlipbot)  &
1612         .and.(zi.lt.bordliptop)) then
1613 !C the energy transfer exist
1614         if (zi.lt.buflipbot) then
1615 !C what fraction I am in
1616          fracinbuf=1.0d0-  &
1617               ((zi-bordlipbot)/lipbufthick)
1618 !C lipbufthick is thickenes of lipid buffore
1619          sslipi=sscalelip(fracinbuf)
1620          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1621         elseif (zi.gt.bufliptop) then
1622          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1623          sslipi=sscalelip(fracinbuf)
1624          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1625         else
1626          sslipi=1.0d0
1627          ssgradlipi=0.0
1628         endif
1629        else
1630          sslipi=0.0d0
1631          ssgradlipi=0.0
1632        endif
1633 !       print *, sslipi,ssgradlipi
1634         dxi=dc_norm(1,nres+i)
1635         dyi=dc_norm(2,nres+i)
1636         dzi=dc_norm(3,nres+i)
1637 !        dsci_inv=dsc_inv(itypi)
1638         dsci_inv=vbld_inv(i+nres)
1639 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1640 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1641 !
1642 ! Calculate SC interaction energy.
1643 !
1644         do iint=1,nint_gr(i)
1645           do j=istart(i,iint),iend(i,iint)
1646             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1647               call dyn_ssbond_ene(i,j,evdwij)
1648               evdw=evdw+evdwij
1649               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1650                               'evdw',i,j,evdwij,' ss'
1651 !              if (energy_dec) write (iout,*) &
1652 !                              'evdw',i,j,evdwij,' ss'
1653              do k=j+1,iend(i,iint)
1654 !C search over all next residues
1655               if (dyn_ss_mask(k)) then
1656 !C check if they are cysteins
1657 !C              write(iout,*) 'k=',k
1658
1659 !c              write(iout,*) "PRZED TRI", evdwij
1660 !               evdwij_przed_tri=evdwij
1661               call triple_ssbond_ene(i,j,k,evdwij)
1662 !c               if(evdwij_przed_tri.ne.evdwij) then
1663 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1664 !c               endif
1665
1666 !c              write(iout,*) "PO TRI", evdwij
1667 !C call the energy function that removes the artifical triple disulfide
1668 !C bond the soubroutine is located in ssMD.F
1669               evdw=evdw+evdwij
1670               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1671                             'evdw',i,j,evdwij,'tss'
1672               endif!dyn_ss_mask(k)
1673              enddo! k
1674             ELSE
1675 !el            ind=ind+1
1676             itypj=iabs(itype(j,1))
1677             if (itypj.eq.ntyp1) cycle
1678 !             if (j.ne.78) cycle
1679 !            dscj_inv=dsc_inv(itypj)
1680             dscj_inv=vbld_inv(j+nres)
1681 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1682 !              1.0d0/vbld(j+nres) !d
1683 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1684             sig0ij=sigma(itypi,itypj)
1685             chi1=chi(itypi,itypj)
1686             chi2=chi(itypj,itypi)
1687             chi12=chi1*chi2
1688             chip1=chip(itypi)
1689             chip2=chip(itypj)
1690             chip12=chip1*chip2
1691             alf1=alp(itypi)
1692             alf2=alp(itypj)
1693             alf12=0.5D0*(alf1+alf2)
1694 ! For diagnostics only!!!
1695 !           chi1=0.0D0
1696 !           chi2=0.0D0
1697 !           chi12=0.0D0
1698 !           chip1=0.0D0
1699 !           chip2=0.0D0
1700 !           chip12=0.0D0
1701 !           alf1=0.0D0
1702 !           alf2=0.0D0
1703 !           alf12=0.0D0
1704            xj=c(1,nres+j)
1705            yj=c(2,nres+j)
1706            zj=c(3,nres+j)
1707           xj=dmod(xj,boxxsize)
1708           if (xj.lt.0) xj=xj+boxxsize
1709           yj=dmod(yj,boxysize)
1710           if (yj.lt.0) yj=yj+boxysize
1711           zj=dmod(zj,boxzsize)
1712           if (zj.lt.0) zj=zj+boxzsize
1713 !          print *,"tu",xi,yi,zi,xj,yj,zj
1714 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1715 ! this fragment set correct epsilon for lipid phase
1716        if ((zj.gt.bordlipbot)  &
1717        .and.(zj.lt.bordliptop)) then
1718 !C the energy transfer exist
1719         if (zj.lt.buflipbot) then
1720 !C what fraction I am in
1721          fracinbuf=1.0d0-     &
1722              ((zj-bordlipbot)/lipbufthick)
1723 !C lipbufthick is thickenes of lipid buffore
1724          sslipj=sscalelip(fracinbuf)
1725          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1726         elseif (zj.gt.bufliptop) then
1727          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1728          sslipj=sscalelip(fracinbuf)
1729          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1730         else
1731          sslipj=1.0d0
1732          ssgradlipj=0.0
1733         endif
1734        else
1735          sslipj=0.0d0
1736          ssgradlipj=0.0
1737        endif
1738       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1739        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1740       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1741        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1742 !------------------------------------------------
1743       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1744       xj_safe=xj
1745       yj_safe=yj
1746       zj_safe=zj
1747       subchap=0
1748       do xshift=-1,1
1749       do yshift=-1,1
1750       do zshift=-1,1
1751           xj=xj_safe+xshift*boxxsize
1752           yj=yj_safe+yshift*boxysize
1753           zj=zj_safe+zshift*boxzsize
1754           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1755           if(dist_temp.lt.dist_init) then
1756             dist_init=dist_temp
1757             xj_temp=xj
1758             yj_temp=yj
1759             zj_temp=zj
1760             subchap=1
1761           endif
1762        enddo
1763        enddo
1764        enddo
1765        if (subchap.eq.1) then
1766           xj=xj_temp-xi
1767           yj=yj_temp-yi
1768           zj=zj_temp-zi
1769        else
1770           xj=xj_safe-xi
1771           yj=yj_safe-yi
1772           zj=zj_safe-zi
1773        endif
1774             dxj=dc_norm(1,nres+j)
1775             dyj=dc_norm(2,nres+j)
1776             dzj=dc_norm(3,nres+j)
1777 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1778 !            write (iout,*) "j",j," dc_norm",& !d
1779 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1780 !          write(iout,*)"rrij ",rrij
1781 !          write(iout,*)"xj yj zj ", xj, yj, zj
1782 !          write(iout,*)"xi yi zi ", xi, yi, zi
1783 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1784             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1785             rij=dsqrt(rrij)
1786             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1787             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1788 !            print *,sss_ele_cut,sss_ele_grad,&
1789 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1790             if (sss_ele_cut.le.0.0) cycle
1791 ! Calculate angle-dependent terms of energy and contributions to their
1792 ! derivatives.
1793             call sc_angular
1794             sigsq=1.0D0/sigsq
1795             sig=sig0ij*dsqrt(sigsq)
1796             rij_shift=1.0D0/rij-sig+sig0ij
1797 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1798 !            "sig0ij",sig0ij
1799 ! for diagnostics; uncomment
1800 !            rij_shift=1.2*sig0ij
1801 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1802             if (rij_shift.le.0.0D0) then
1803               evdw=1.0D20
1804 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1805 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1806 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1807               return
1808             endif
1809             sigder=-sig*sigsq
1810 !---------------------------------------------------------------
1811             rij_shift=1.0D0/rij_shift
1812             fac=rij_shift**expon
1813             faclip=fac
1814             e1=fac*fac*aa!(itypi,itypj)
1815             e2=fac*bb!(itypi,itypj)
1816             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1817             eps2der=evdwij*eps3rt
1818             eps3der=evdwij*eps2rt
1819 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1820 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1821 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1822             evdwij=evdwij*eps2rt*eps3rt
1823             evdw=evdw+evdwij*sss_ele_cut
1824             if (lprn) then
1825             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1826             epsi=bb**2/aa!(itypi,itypj)
1827             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1828               restyp(itypi,1),i,restyp(itypj,1),j, &
1829               epsi,sigm,chi1,chi2,chip1,chip2, &
1830               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1831               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1832               evdwij
1833             endif
1834
1835             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1836                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1837 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1838 !            if (energy_dec) write (iout,*) &
1839 !                             'evdw',i,j,evdwij
1840 !                       print *,"ZALAMKA", evdw
1841
1842 ! Calculate gradient components.
1843             e1=e1*eps1*eps2rt**2*eps3rt**2
1844             fac=-expon*(e1+evdwij)*rij_shift
1845             sigder=fac*sigder
1846             fac=rij*fac
1847 !            print *,'before fac',fac,rij,evdwij
1848             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1849             /sigma(itypi,itypj)*rij
1850 !            print *,'grad part scale',fac,   &
1851 !             evdwij*sss_ele_grad/sss_ele_cut &
1852 !            /sigma(itypi,itypj)*rij
1853 !            fac=0.0d0
1854 ! Calculate the radial part of the gradient
1855             gg(1)=xj*fac
1856             gg(2)=yj*fac
1857             gg(3)=zj*fac
1858 !C Calculate the radial part of the gradient
1859             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1860        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1861         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1862        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1863             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1864             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1865
1866 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1867 ! Calculate angular part of the gradient.
1868             call sc_grad
1869             ENDIF    ! dyn_ss
1870           enddo      ! j
1871         enddo        ! iint
1872       enddo          ! i
1873 !       print *,"ZALAMKA", evdw
1874 !      write (iout,*) "Number of loop steps in EGB:",ind
1875 !ccc      energy_dec=.false.
1876       return
1877       end subroutine egb
1878 !-----------------------------------------------------------------------------
1879       subroutine egbv(evdw)
1880 !
1881 ! This subroutine calculates the interaction energy of nonbonded side chains
1882 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1883 !
1884       use comm_srutu
1885       use calc_data
1886 !      implicit real*8 (a-h,o-z)
1887 !      include 'DIMENSIONS'
1888 !      include 'COMMON.GEO'
1889 !      include 'COMMON.VAR'
1890 !      include 'COMMON.LOCAL'
1891 !      include 'COMMON.CHAIN'
1892 !      include 'COMMON.DERIV'
1893 !      include 'COMMON.NAMES'
1894 !      include 'COMMON.INTERACT'
1895 !      include 'COMMON.IOUNITS'
1896 !      include 'COMMON.CALC'
1897       use comm_srutu
1898 !el      integer :: icall
1899 !el      common /srutu/ icall
1900       logical :: lprn
1901 !el local variables
1902       integer :: iint,itypi,itypi1,itypj
1903       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1904       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1905
1906 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1907       evdw=0.0D0
1908       lprn=.false.
1909 !     if (icall.eq.0) lprn=.true.
1910 !el      ind=0
1911       do i=iatsc_s,iatsc_e
1912         itypi=iabs(itype(i,1))
1913         if (itypi.eq.ntyp1) cycle
1914         itypi1=iabs(itype(i+1,1))
1915         xi=c(1,nres+i)
1916         yi=c(2,nres+i)
1917         zi=c(3,nres+i)
1918         dxi=dc_norm(1,nres+i)
1919         dyi=dc_norm(2,nres+i)
1920         dzi=dc_norm(3,nres+i)
1921 !        dsci_inv=dsc_inv(itypi)
1922         dsci_inv=vbld_inv(i+nres)
1923 !
1924 ! Calculate SC interaction energy.
1925 !
1926         do iint=1,nint_gr(i)
1927           do j=istart(i,iint),iend(i,iint)
1928 !el            ind=ind+1
1929             itypj=iabs(itype(j,1))
1930             if (itypj.eq.ntyp1) cycle
1931 !            dscj_inv=dsc_inv(itypj)
1932             dscj_inv=vbld_inv(j+nres)
1933             sig0ij=sigma(itypi,itypj)
1934             r0ij=r0(itypi,itypj)
1935             chi1=chi(itypi,itypj)
1936             chi2=chi(itypj,itypi)
1937             chi12=chi1*chi2
1938             chip1=chip(itypi)
1939             chip2=chip(itypj)
1940             chip12=chip1*chip2
1941             alf1=alp(itypi)
1942             alf2=alp(itypj)
1943             alf12=0.5D0*(alf1+alf2)
1944 ! For diagnostics only!!!
1945 !           chi1=0.0D0
1946 !           chi2=0.0D0
1947 !           chi12=0.0D0
1948 !           chip1=0.0D0
1949 !           chip2=0.0D0
1950 !           chip12=0.0D0
1951 !           alf1=0.0D0
1952 !           alf2=0.0D0
1953 !           alf12=0.0D0
1954             xj=c(1,nres+j)-xi
1955             yj=c(2,nres+j)-yi
1956             zj=c(3,nres+j)-zi
1957             dxj=dc_norm(1,nres+j)
1958             dyj=dc_norm(2,nres+j)
1959             dzj=dc_norm(3,nres+j)
1960             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1961             rij=dsqrt(rrij)
1962 ! Calculate angle-dependent terms of energy and contributions to their
1963 ! derivatives.
1964             call sc_angular
1965             sigsq=1.0D0/sigsq
1966             sig=sig0ij*dsqrt(sigsq)
1967             rij_shift=1.0D0/rij-sig+r0ij
1968 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1969             if (rij_shift.le.0.0D0) then
1970               evdw=1.0D20
1971               return
1972             endif
1973             sigder=-sig*sigsq
1974 !---------------------------------------------------------------
1975             rij_shift=1.0D0/rij_shift
1976             fac=rij_shift**expon
1977             e1=fac*fac*aa_aq(itypi,itypj)
1978             e2=fac*bb_aq(itypi,itypj)
1979             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1980             eps2der=evdwij*eps3rt
1981             eps3der=evdwij*eps2rt
1982             fac_augm=rrij**expon
1983             e_augm=augm(itypi,itypj)*fac_augm
1984             evdwij=evdwij*eps2rt*eps3rt
1985             evdw=evdw+evdwij+e_augm
1986             if (lprn) then
1987             sigm=dabs(aa_aq(itypi,itypj)/&
1988             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1989             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1990             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1991               restyp(itypi,1),i,restyp(itypj,1),j,&
1992               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1993               chi1,chi2,chip1,chip2,&
1994               eps1,eps2rt**2,eps3rt**2,&
1995               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1996               evdwij+e_augm
1997             endif
1998 ! Calculate gradient components.
1999             e1=e1*eps1*eps2rt**2*eps3rt**2
2000             fac=-expon*(e1+evdwij)*rij_shift
2001             sigder=fac*sigder
2002             fac=rij*fac-2*expon*rrij*e_augm
2003 ! Calculate the radial part of the gradient
2004             gg(1)=xj*fac
2005             gg(2)=yj*fac
2006             gg(3)=zj*fac
2007 ! Calculate angular part of the gradient.
2008             call sc_grad
2009           enddo      ! j
2010         enddo        ! iint
2011       enddo          ! i
2012       end subroutine egbv
2013 !-----------------------------------------------------------------------------
2014 !el      subroutine sc_angular in module geometry
2015 !-----------------------------------------------------------------------------
2016       subroutine e_softsphere(evdw)
2017 !
2018 ! This subroutine calculates the interaction energy of nonbonded side chains
2019 ! assuming the LJ potential of interaction.
2020 !
2021 !      implicit real*8 (a-h,o-z)
2022 !      include 'DIMENSIONS'
2023       real(kind=8),parameter :: accur=1.0d-10
2024 !      include 'COMMON.GEO'
2025 !      include 'COMMON.VAR'
2026 !      include 'COMMON.LOCAL'
2027 !      include 'COMMON.CHAIN'
2028 !      include 'COMMON.DERIV'
2029 !      include 'COMMON.INTERACT'
2030 !      include 'COMMON.TORSION'
2031 !      include 'COMMON.SBRIDGE'
2032 !      include 'COMMON.NAMES'
2033 !      include 'COMMON.IOUNITS'
2034 !      include 'COMMON.CONTACTS'
2035       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2036 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2037 !el local variables
2038       integer :: i,iint,j,itypi,itypi1,itypj,k
2039       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2040       real(kind=8) :: fac
2041
2042       evdw=0.0D0
2043       do i=iatsc_s,iatsc_e
2044         itypi=iabs(itype(i,1))
2045         if (itypi.eq.ntyp1) cycle
2046         itypi1=iabs(itype(i+1,1))
2047         xi=c(1,nres+i)
2048         yi=c(2,nres+i)
2049         zi=c(3,nres+i)
2050 !
2051 ! Calculate SC interaction energy.
2052 !
2053         do iint=1,nint_gr(i)
2054 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2055 !d   &                  'iend=',iend(i,iint)
2056           do j=istart(i,iint),iend(i,iint)
2057             itypj=iabs(itype(j,1))
2058             if (itypj.eq.ntyp1) cycle
2059             xj=c(1,nres+j)-xi
2060             yj=c(2,nres+j)-yi
2061             zj=c(3,nres+j)-zi
2062             rij=xj*xj+yj*yj+zj*zj
2063 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2064             r0ij=r0(itypi,itypj)
2065             r0ijsq=r0ij*r0ij
2066 !            print *,i,j,r0ij,dsqrt(rij)
2067             if (rij.lt.r0ijsq) then
2068               evdwij=0.25d0*(rij-r0ijsq)**2
2069               fac=rij-r0ijsq
2070             else
2071               evdwij=0.0d0
2072               fac=0.0d0
2073             endif
2074             evdw=evdw+evdwij
2075 !
2076 ! Calculate the components of the gradient in DC and X
2077 !
2078             gg(1)=xj*fac
2079             gg(2)=yj*fac
2080             gg(3)=zj*fac
2081             do k=1,3
2082               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2083               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2084               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2085               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2086             enddo
2087 !grad            do k=i,j-1
2088 !grad              do l=1,3
2089 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2090 !grad              enddo
2091 !grad            enddo
2092           enddo ! j
2093         enddo ! iint
2094       enddo ! i
2095       return
2096       end subroutine e_softsphere
2097 !-----------------------------------------------------------------------------
2098       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2099 !
2100 ! Soft-sphere potential of p-p interaction
2101 !
2102 !      implicit real*8 (a-h,o-z)
2103 !      include 'DIMENSIONS'
2104 !      include 'COMMON.CONTROL'
2105 !      include 'COMMON.IOUNITS'
2106 !      include 'COMMON.GEO'
2107 !      include 'COMMON.VAR'
2108 !      include 'COMMON.LOCAL'
2109 !      include 'COMMON.CHAIN'
2110 !      include 'COMMON.DERIV'
2111 !      include 'COMMON.INTERACT'
2112 !      include 'COMMON.CONTACTS'
2113 !      include 'COMMON.TORSION'
2114 !      include 'COMMON.VECTORS'
2115 !      include 'COMMON.FFIELD'
2116       real(kind=8),dimension(3) :: ggg
2117 !d      write(iout,*) 'In EELEC_soft_sphere'
2118 !el local variables
2119       integer :: i,j,k,num_conti,iteli,itelj
2120       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2121       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2122       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2123
2124       ees=0.0D0
2125       evdw1=0.0D0
2126       eel_loc=0.0d0
2127       eello_turn3=0.0d0
2128       eello_turn4=0.0d0
2129 !el      ind=0
2130       do i=iatel_s,iatel_e
2131         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2132         dxi=dc(1,i)
2133         dyi=dc(2,i)
2134         dzi=dc(3,i)
2135         xmedi=c(1,i)+0.5d0*dxi
2136         ymedi=c(2,i)+0.5d0*dyi
2137         zmedi=c(3,i)+0.5d0*dzi
2138         num_conti=0
2139 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2140         do j=ielstart(i),ielend(i)
2141           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2142 !el          ind=ind+1
2143           iteli=itel(i)
2144           itelj=itel(j)
2145           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2146           r0ij=rpp(iteli,itelj)
2147           r0ijsq=r0ij*r0ij
2148           dxj=dc(1,j)
2149           dyj=dc(2,j)
2150           dzj=dc(3,j)
2151           xj=c(1,j)+0.5D0*dxj-xmedi
2152           yj=c(2,j)+0.5D0*dyj-ymedi
2153           zj=c(3,j)+0.5D0*dzj-zmedi
2154           rij=xj*xj+yj*yj+zj*zj
2155           if (rij.lt.r0ijsq) then
2156             evdw1ij=0.25d0*(rij-r0ijsq)**2
2157             fac=rij-r0ijsq
2158           else
2159             evdw1ij=0.0d0
2160             fac=0.0d0
2161           endif
2162           evdw1=evdw1+evdw1ij
2163 !
2164 ! Calculate contributions to the Cartesian gradient.
2165 !
2166           ggg(1)=fac*xj
2167           ggg(2)=fac*yj
2168           ggg(3)=fac*zj
2169           do k=1,3
2170             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2171             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2172           enddo
2173 !
2174 ! Loop over residues i+1 thru j-1.
2175 !
2176 !grad          do k=i+1,j-1
2177 !grad            do l=1,3
2178 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2179 !grad            enddo
2180 !grad          enddo
2181         enddo ! j
2182       enddo   ! i
2183 !grad      do i=nnt,nct-1
2184 !grad        do k=1,3
2185 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2186 !grad        enddo
2187 !grad        do j=i+1,nct-1
2188 !grad          do k=1,3
2189 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2190 !grad          enddo
2191 !grad        enddo
2192 !grad      enddo
2193       return
2194       end subroutine eelec_soft_sphere
2195 !-----------------------------------------------------------------------------
2196       subroutine vec_and_deriv
2197 !      implicit real*8 (a-h,o-z)
2198 !      include 'DIMENSIONS'
2199 #ifdef MPI
2200       include 'mpif.h'
2201 #endif
2202 !      include 'COMMON.IOUNITS'
2203 !      include 'COMMON.GEO'
2204 !      include 'COMMON.VAR'
2205 !      include 'COMMON.LOCAL'
2206 !      include 'COMMON.CHAIN'
2207 !      include 'COMMON.VECTORS'
2208 !      include 'COMMON.SETUP'
2209 !      include 'COMMON.TIME1'
2210       real(kind=8),dimension(3,3,2) :: uyder,uzder
2211       real(kind=8),dimension(2) :: vbld_inv_temp
2212 ! Compute the local reference systems. For reference system (i), the
2213 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2214 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2215 !el local variables
2216       integer :: i,j,k,l
2217       real(kind=8) :: facy,fac,costh
2218
2219 #ifdef PARVEC
2220       do i=ivec_start,ivec_end
2221 #else
2222       do i=1,nres-1
2223 #endif
2224           if (i.eq.nres-1) then
2225 ! Case of the last full residue
2226 ! Compute the Z-axis
2227             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2228             costh=dcos(pi-theta(nres))
2229             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2230             do k=1,3
2231               uz(k,i)=fac*uz(k,i)
2232             enddo
2233 ! Compute the derivatives of uz
2234             uzder(1,1,1)= 0.0d0
2235             uzder(2,1,1)=-dc_norm(3,i-1)
2236             uzder(3,1,1)= dc_norm(2,i-1)
2237             uzder(1,2,1)= dc_norm(3,i-1)
2238             uzder(2,2,1)= 0.0d0
2239             uzder(3,2,1)=-dc_norm(1,i-1)
2240             uzder(1,3,1)=-dc_norm(2,i-1)
2241             uzder(2,3,1)= dc_norm(1,i-1)
2242             uzder(3,3,1)= 0.0d0
2243             uzder(1,1,2)= 0.0d0
2244             uzder(2,1,2)= dc_norm(3,i)
2245             uzder(3,1,2)=-dc_norm(2,i)
2246             uzder(1,2,2)=-dc_norm(3,i)
2247             uzder(2,2,2)= 0.0d0
2248             uzder(3,2,2)= dc_norm(1,i)
2249             uzder(1,3,2)= dc_norm(2,i)
2250             uzder(2,3,2)=-dc_norm(1,i)
2251             uzder(3,3,2)= 0.0d0
2252 ! Compute the Y-axis
2253             facy=fac
2254             do k=1,3
2255               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2256             enddo
2257 ! Compute the derivatives of uy
2258             do j=1,3
2259               do k=1,3
2260                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2261                               -dc_norm(k,i)*dc_norm(j,i-1)
2262                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2263               enddo
2264               uyder(j,j,1)=uyder(j,j,1)-costh
2265               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2266             enddo
2267             do j=1,2
2268               do k=1,3
2269                 do l=1,3
2270                   uygrad(l,k,j,i)=uyder(l,k,j)
2271                   uzgrad(l,k,j,i)=uzder(l,k,j)
2272                 enddo
2273               enddo
2274             enddo
2275             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2276             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2277             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2278             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2279           else
2280 ! Other residues
2281 ! Compute the Z-axis
2282             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2283             costh=dcos(pi-theta(i+2))
2284             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2285             do k=1,3
2286               uz(k,i)=fac*uz(k,i)
2287             enddo
2288 ! Compute the derivatives of uz
2289             uzder(1,1,1)= 0.0d0
2290             uzder(2,1,1)=-dc_norm(3,i+1)
2291             uzder(3,1,1)= dc_norm(2,i+1)
2292             uzder(1,2,1)= dc_norm(3,i+1)
2293             uzder(2,2,1)= 0.0d0
2294             uzder(3,2,1)=-dc_norm(1,i+1)
2295             uzder(1,3,1)=-dc_norm(2,i+1)
2296             uzder(2,3,1)= dc_norm(1,i+1)
2297             uzder(3,3,1)= 0.0d0
2298             uzder(1,1,2)= 0.0d0
2299             uzder(2,1,2)= dc_norm(3,i)
2300             uzder(3,1,2)=-dc_norm(2,i)
2301             uzder(1,2,2)=-dc_norm(3,i)
2302             uzder(2,2,2)= 0.0d0
2303             uzder(3,2,2)= dc_norm(1,i)
2304             uzder(1,3,2)= dc_norm(2,i)
2305             uzder(2,3,2)=-dc_norm(1,i)
2306             uzder(3,3,2)= 0.0d0
2307 ! Compute the Y-axis
2308             facy=fac
2309             do k=1,3
2310               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2311             enddo
2312 ! Compute the derivatives of uy
2313             do j=1,3
2314               do k=1,3
2315                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2316                               -dc_norm(k,i)*dc_norm(j,i+1)
2317                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2318               enddo
2319               uyder(j,j,1)=uyder(j,j,1)-costh
2320               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2321             enddo
2322             do j=1,2
2323               do k=1,3
2324                 do l=1,3
2325                   uygrad(l,k,j,i)=uyder(l,k,j)
2326                   uzgrad(l,k,j,i)=uzder(l,k,j)
2327                 enddo
2328               enddo
2329             enddo
2330             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2331             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2332             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2333             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2334           endif
2335       enddo
2336       do i=1,nres-1
2337         vbld_inv_temp(1)=vbld_inv(i+1)
2338         if (i.lt.nres-1) then
2339           vbld_inv_temp(2)=vbld_inv(i+2)
2340           else
2341           vbld_inv_temp(2)=vbld_inv(i)
2342           endif
2343         do j=1,2
2344           do k=1,3
2345             do l=1,3
2346               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2347               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2348             enddo
2349           enddo
2350         enddo
2351       enddo
2352 #if defined(PARVEC) && defined(MPI)
2353       if (nfgtasks1.gt.1) then
2354         time00=MPI_Wtime()
2355 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2356 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2357 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2358         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2359          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2360          FG_COMM1,IERR)
2361         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2362          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2363          FG_COMM1,IERR)
2364         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2365          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2366          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2367         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2368          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2369          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2370         time_gather=time_gather+MPI_Wtime()-time00
2371       endif
2372 !      if (fg_rank.eq.0) then
2373 !        write (iout,*) "Arrays UY and UZ"
2374 !        do i=1,nres-1
2375 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2376 !     &     (uz(k,i),k=1,3)
2377 !        enddo
2378 !      endif
2379 #endif
2380       return
2381       end subroutine vec_and_deriv
2382 !-----------------------------------------------------------------------------
2383       subroutine check_vecgrad
2384 !      implicit real*8 (a-h,o-z)
2385 !      include 'DIMENSIONS'
2386 !      include 'COMMON.IOUNITS'
2387 !      include 'COMMON.GEO'
2388 !      include 'COMMON.VAR'
2389 !      include 'COMMON.LOCAL'
2390 !      include 'COMMON.CHAIN'
2391 !      include 'COMMON.VECTORS'
2392       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2393       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2394       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2395       real(kind=8),dimension(3) :: erij
2396       real(kind=8) :: delta=1.0d-7
2397 !el local variables
2398       integer :: i,j,k,l
2399
2400       call vec_and_deriv
2401 !d      do i=1,nres
2402 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2403 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2404 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2405 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2406 !d     &     (dc_norm(if90,i),if90=1,3)
2407 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2408 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2409 !d          write(iout,'(a)')
2410 !d      enddo
2411       do i=1,nres
2412         do j=1,2
2413           do k=1,3
2414             do l=1,3
2415               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2416               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2417             enddo
2418           enddo
2419         enddo
2420       enddo
2421       call vec_and_deriv
2422       do i=1,nres
2423         do j=1,3
2424           uyt(j,i)=uy(j,i)
2425           uzt(j,i)=uz(j,i)
2426         enddo
2427       enddo
2428       do i=1,nres
2429 !d        write (iout,*) 'i=',i
2430         do k=1,3
2431           erij(k)=dc_norm(k,i)
2432         enddo
2433         do j=1,3
2434           do k=1,3
2435             dc_norm(k,i)=erij(k)
2436           enddo
2437           dc_norm(j,i)=dc_norm(j,i)+delta
2438 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2439 !          do k=1,3
2440 !            dc_norm(k,i)=dc_norm(k,i)/fac
2441 !          enddo
2442 !          write (iout,*) (dc_norm(k,i),k=1,3)
2443 !          write (iout,*) (erij(k),k=1,3)
2444           call vec_and_deriv
2445           do k=1,3
2446             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2447             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2448             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2449             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2450           enddo
2451 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2452 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2453 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2454         enddo
2455         do k=1,3
2456           dc_norm(k,i)=erij(k)
2457         enddo
2458 !d        do k=1,3
2459 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2460 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2461 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2462 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2463 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2464 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2465 !d          write (iout,'(a)')
2466 !d        enddo
2467       enddo
2468       return
2469       end subroutine check_vecgrad
2470 !-----------------------------------------------------------------------------
2471       subroutine set_matrices
2472 !      implicit real*8 (a-h,o-z)
2473 !      include 'DIMENSIONS'
2474 #ifdef MPI
2475       include "mpif.h"
2476 !      include "COMMON.SETUP"
2477       integer :: IERR
2478       integer :: status(MPI_STATUS_SIZE)
2479 #endif
2480 !      include 'COMMON.IOUNITS'
2481 !      include 'COMMON.GEO'
2482 !      include 'COMMON.VAR'
2483 !      include 'COMMON.LOCAL'
2484 !      include 'COMMON.CHAIN'
2485 !      include 'COMMON.DERIV'
2486 !      include 'COMMON.INTERACT'
2487 !      include 'COMMON.CONTACTS'
2488 !      include 'COMMON.TORSION'
2489 !      include 'COMMON.VECTORS'
2490 !      include 'COMMON.FFIELD'
2491       real(kind=8) :: auxvec(2),auxmat(2,2)
2492       integer :: i,iti1,iti,k,l
2493       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2494 !       print *,"in set matrices"
2495 !
2496 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2497 ! to calculate the el-loc multibody terms of various order.
2498 !
2499 !AL el      mu=0.0d0
2500 #ifdef PARMAT
2501       do i=ivec_start+2,ivec_end+2
2502 #else
2503       do i=3,nres+1
2504 #endif
2505 !      print *,i,"i"
2506         if (i .lt. nres+1) then
2507           sin1=dsin(phi(i))
2508           cos1=dcos(phi(i))
2509           sintab(i-2)=sin1
2510           costab(i-2)=cos1
2511           obrot(1,i-2)=cos1
2512           obrot(2,i-2)=sin1
2513           sin2=dsin(2*phi(i))
2514           cos2=dcos(2*phi(i))
2515           sintab2(i-2)=sin2
2516           costab2(i-2)=cos2
2517           obrot2(1,i-2)=cos2
2518           obrot2(2,i-2)=sin2
2519           Ug(1,1,i-2)=-cos1
2520           Ug(1,2,i-2)=-sin1
2521           Ug(2,1,i-2)=-sin1
2522           Ug(2,2,i-2)= cos1
2523           Ug2(1,1,i-2)=-cos2
2524           Ug2(1,2,i-2)=-sin2
2525           Ug2(2,1,i-2)=-sin2
2526           Ug2(2,2,i-2)= cos2
2527         else
2528           costab(i-2)=1.0d0
2529           sintab(i-2)=0.0d0
2530           obrot(1,i-2)=1.0d0
2531           obrot(2,i-2)=0.0d0
2532           obrot2(1,i-2)=0.0d0
2533           obrot2(2,i-2)=0.0d0
2534           Ug(1,1,i-2)=1.0d0
2535           Ug(1,2,i-2)=0.0d0
2536           Ug(2,1,i-2)=0.0d0
2537           Ug(2,2,i-2)=1.0d0
2538           Ug2(1,1,i-2)=0.0d0
2539           Ug2(1,2,i-2)=0.0d0
2540           Ug2(2,1,i-2)=0.0d0
2541           Ug2(2,2,i-2)=0.0d0
2542         endif
2543         if (i .gt. 3 .and. i .lt. nres+1) then
2544           obrot_der(1,i-2)=-sin1
2545           obrot_der(2,i-2)= cos1
2546           Ugder(1,1,i-2)= sin1
2547           Ugder(1,2,i-2)=-cos1
2548           Ugder(2,1,i-2)=-cos1
2549           Ugder(2,2,i-2)=-sin1
2550           dwacos2=cos2+cos2
2551           dwasin2=sin2+sin2
2552           obrot2_der(1,i-2)=-dwasin2
2553           obrot2_der(2,i-2)= dwacos2
2554           Ug2der(1,1,i-2)= dwasin2
2555           Ug2der(1,2,i-2)=-dwacos2
2556           Ug2der(2,1,i-2)=-dwacos2
2557           Ug2der(2,2,i-2)=-dwasin2
2558         else
2559           obrot_der(1,i-2)=0.0d0
2560           obrot_der(2,i-2)=0.0d0
2561           Ugder(1,1,i-2)=0.0d0
2562           Ugder(1,2,i-2)=0.0d0
2563           Ugder(2,1,i-2)=0.0d0
2564           Ugder(2,2,i-2)=0.0d0
2565           obrot2_der(1,i-2)=0.0d0
2566           obrot2_der(2,i-2)=0.0d0
2567           Ug2der(1,1,i-2)=0.0d0
2568           Ug2der(1,2,i-2)=0.0d0
2569           Ug2der(2,1,i-2)=0.0d0
2570           Ug2der(2,2,i-2)=0.0d0
2571         endif
2572 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2573         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2574           iti = itortyp(itype(i-2,1))
2575         else
2576           iti=ntortyp+1
2577         endif
2578 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2579         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2580           iti1 = itortyp(itype(i-1,1))
2581         else
2582           iti1=ntortyp+1
2583         endif
2584 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2585 !d        write (iout,*) '*******i',i,' iti1',iti
2586 !d        write (iout,*) 'b1',b1(:,iti)
2587 !d        write (iout,*) 'b2',b2(:,iti)
2588 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2589 !        if (i .gt. iatel_s+2) then
2590         if (i .gt. nnt+2) then
2591           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2592           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2593           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2594           then
2595           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2596           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2597           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2598           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2599           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2600           endif
2601         else
2602           do k=1,2
2603             Ub2(k,i-2)=0.0d0
2604             Ctobr(k,i-2)=0.0d0
2605             Dtobr2(k,i-2)=0.0d0
2606             do l=1,2
2607               EUg(l,k,i-2)=0.0d0
2608               CUg(l,k,i-2)=0.0d0
2609               DUg(l,k,i-2)=0.0d0
2610               DtUg2(l,k,i-2)=0.0d0
2611             enddo
2612           enddo
2613         endif
2614         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2615         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2616         do k=1,2
2617           muder(k,i-2)=Ub2der(k,i-2)
2618         enddo
2619 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2620         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2621           if (itype(i-1,1).le.ntyp) then
2622             iti1 = itortyp(itype(i-1,1))
2623           else
2624             iti1=ntortyp+1
2625           endif
2626         else
2627           iti1=ntortyp+1
2628         endif
2629         do k=1,2
2630           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2631         enddo
2632 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2633 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2634 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2635 !d        write (iout,*) 'mu1',mu1(:,i-2)
2636 !d        write (iout,*) 'mu2',mu2(:,i-2)
2637         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2638         then
2639         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2640         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2641         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2642         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2643         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2644 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2645         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2646         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2647         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2648         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2649         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2650         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2651         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2652         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2653         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2654         endif
2655       enddo
2656 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2657 ! The order of matrices is from left to right.
2658       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2659       then
2660 !      do i=max0(ivec_start,2),ivec_end
2661       do i=2,nres-1
2662         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2663         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2664         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2665         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2666         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2667         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2668         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2669         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2670       enddo
2671       endif
2672 #if defined(MPI) && defined(PARMAT)
2673 #ifdef DEBUG
2674 !      if (fg_rank.eq.0) then
2675         write (iout,*) "Arrays UG and UGDER before GATHER"
2676         do i=1,nres-1
2677           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2678            ((ug(l,k,i),l=1,2),k=1,2),&
2679            ((ugder(l,k,i),l=1,2),k=1,2)
2680         enddo
2681         write (iout,*) "Arrays UG2 and UG2DER"
2682         do i=1,nres-1
2683           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2684            ((ug2(l,k,i),l=1,2),k=1,2),&
2685            ((ug2der(l,k,i),l=1,2),k=1,2)
2686         enddo
2687         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2688         do i=1,nres-1
2689           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2690            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2691            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2692         enddo
2693         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2694         do i=1,nres-1
2695           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2696            costab(i),sintab(i),costab2(i),sintab2(i)
2697         enddo
2698         write (iout,*) "Array MUDER"
2699         do i=1,nres-1
2700           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2701         enddo
2702 !      endif
2703 #endif
2704       if (nfgtasks.gt.1) then
2705         time00=MPI_Wtime()
2706 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2707 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2708 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2709 #ifdef MATGATHER
2710         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2711          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2712          FG_COMM1,IERR)
2713         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2714          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2715          FG_COMM1,IERR)
2716         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2717          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2718          FG_COMM1,IERR)
2719         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2720          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2721          FG_COMM1,IERR)
2722         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2723          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2724          FG_COMM1,IERR)
2725         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2726          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2727          FG_COMM1,IERR)
2728         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2729          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2730          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2731         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2732          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2733          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2734         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2735          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2736          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2737         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2738          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2739          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2740         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2741         then
2742         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2743          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2744          FG_COMM1,IERR)
2745         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2746          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2747          FG_COMM1,IERR)
2748         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2749          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2750          FG_COMM1,IERR)
2751        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2752          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2753          FG_COMM1,IERR)
2754         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2755          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2756          FG_COMM1,IERR)
2757         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2758          ivec_count(fg_rank1),&
2759          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2760          FG_COMM1,IERR)
2761         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2762          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2763          FG_COMM1,IERR)
2764         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2765          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2766          FG_COMM1,IERR)
2767         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2768          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2769          FG_COMM1,IERR)
2770         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2771          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2772          FG_COMM1,IERR)
2773         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2774          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2775          FG_COMM1,IERR)
2776         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2777          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2778          FG_COMM1,IERR)
2779         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2780          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2781          FG_COMM1,IERR)
2782         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2783          ivec_count(fg_rank1),&
2784          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2785          FG_COMM1,IERR)
2786         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2787          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2788          FG_COMM1,IERR)
2789        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2790          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2791          FG_COMM1,IERR)
2792         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2793          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2794          FG_COMM1,IERR)
2795        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2796          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2797          FG_COMM1,IERR)
2798         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2799          ivec_count(fg_rank1),&
2800          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2801          FG_COMM1,IERR)
2802         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2803          ivec_count(fg_rank1),&
2804          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2805          FG_COMM1,IERR)
2806         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2807          ivec_count(fg_rank1),&
2808          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2809          MPI_MAT2,FG_COMM1,IERR)
2810         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2811          ivec_count(fg_rank1),&
2812          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2813          MPI_MAT2,FG_COMM1,IERR)
2814         endif
2815 #else
2816 ! Passes matrix info through the ring
2817       isend=fg_rank1
2818       irecv=fg_rank1-1
2819       if (irecv.lt.0) irecv=nfgtasks1-1
2820       iprev=irecv
2821       inext=fg_rank1+1
2822       if (inext.ge.nfgtasks1) inext=0
2823       do i=1,nfgtasks1-1
2824 !        write (iout,*) "isend",isend," irecv",irecv
2825 !        call flush(iout)
2826         lensend=lentyp(isend)
2827         lenrecv=lentyp(irecv)
2828 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2829 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2830 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2831 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2832 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2833 !        write (iout,*) "Gather ROTAT1"
2834 !        call flush(iout)
2835 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2836 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2837 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2838 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2839 !        write (iout,*) "Gather ROTAT2"
2840 !        call flush(iout)
2841         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2842          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2843          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2844          iprev,4400+irecv,FG_COMM,status,IERR)
2845 !        write (iout,*) "Gather ROTAT_OLD"
2846 !        call flush(iout)
2847         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2848          MPI_PRECOMP11(lensend),inext,5500+isend,&
2849          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2850          iprev,5500+irecv,FG_COMM,status,IERR)
2851 !        write (iout,*) "Gather PRECOMP11"
2852 !        call flush(iout)
2853         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2854          MPI_PRECOMP12(lensend),inext,6600+isend,&
2855          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2856          iprev,6600+irecv,FG_COMM,status,IERR)
2857 !        write (iout,*) "Gather PRECOMP12"
2858 !        call flush(iout)
2859         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2860         then
2861         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2862          MPI_ROTAT2(lensend),inext,7700+isend,&
2863          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2864          iprev,7700+irecv,FG_COMM,status,IERR)
2865 !        write (iout,*) "Gather PRECOMP21"
2866 !        call flush(iout)
2867         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2868          MPI_PRECOMP22(lensend),inext,8800+isend,&
2869          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2870          iprev,8800+irecv,FG_COMM,status,IERR)
2871 !        write (iout,*) "Gather PRECOMP22"
2872 !        call flush(iout)
2873         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2874          MPI_PRECOMP23(lensend),inext,9900+isend,&
2875          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2876          MPI_PRECOMP23(lenrecv),&
2877          iprev,9900+irecv,FG_COMM,status,IERR)
2878 !        write (iout,*) "Gather PRECOMP23"
2879 !        call flush(iout)
2880         endif
2881         isend=irecv
2882         irecv=irecv-1
2883         if (irecv.lt.0) irecv=nfgtasks1-1
2884       enddo
2885 #endif
2886         time_gather=time_gather+MPI_Wtime()-time00
2887       endif
2888 #ifdef DEBUG
2889 !      if (fg_rank.eq.0) then
2890         write (iout,*) "Arrays UG and UGDER"
2891         do i=1,nres-1
2892           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2893            ((ug(l,k,i),l=1,2),k=1,2),&
2894            ((ugder(l,k,i),l=1,2),k=1,2)
2895         enddo
2896         write (iout,*) "Arrays UG2 and UG2DER"
2897         do i=1,nres-1
2898           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2899            ((ug2(l,k,i),l=1,2),k=1,2),&
2900            ((ug2der(l,k,i),l=1,2),k=1,2)
2901         enddo
2902         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2903         do i=1,nres-1
2904           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2905            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2906            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2907         enddo
2908         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2909         do i=1,nres-1
2910           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2911            costab(i),sintab(i),costab2(i),sintab2(i)
2912         enddo
2913         write (iout,*) "Array MUDER"
2914         do i=1,nres-1
2915           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2916         enddo
2917 !      endif
2918 #endif
2919 #endif
2920 !d      do i=1,nres
2921 !d        iti = itortyp(itype(i,1))
2922 !d        write (iout,*) i
2923 !d        do j=1,2
2924 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2925 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2926 !d        enddo
2927 !d      enddo
2928       return
2929       end subroutine set_matrices
2930 !-----------------------------------------------------------------------------
2931       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2932 !
2933 ! This subroutine calculates the average interaction energy and its gradient
2934 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2935 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2936 ! The potential depends both on the distance of peptide-group centers and on
2937 ! the orientation of the CA-CA virtual bonds.
2938 !
2939       use comm_locel
2940 !      implicit real*8 (a-h,o-z)
2941 #ifdef MPI
2942       include 'mpif.h'
2943 #endif
2944 !      include 'DIMENSIONS'
2945 !      include 'COMMON.CONTROL'
2946 !      include 'COMMON.SETUP'
2947 !      include 'COMMON.IOUNITS'
2948 !      include 'COMMON.GEO'
2949 !      include 'COMMON.VAR'
2950 !      include 'COMMON.LOCAL'
2951 !      include 'COMMON.CHAIN'
2952 !      include 'COMMON.DERIV'
2953 !      include 'COMMON.INTERACT'
2954 !      include 'COMMON.CONTACTS'
2955 !      include 'COMMON.TORSION'
2956 !      include 'COMMON.VECTORS'
2957 !      include 'COMMON.FFIELD'
2958 !      include 'COMMON.TIME1'
2959       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2960       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2961       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2962 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2963       real(kind=8),dimension(4) :: muij
2964 !el      integer :: num_conti,j1,j2
2965 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2966 !el        dz_normi,xmedi,ymedi,zmedi
2967
2968 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2969 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2970 !el          num_conti,j1,j2
2971
2972 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2973 #ifdef MOMENT
2974       real(kind=8) :: scal_el=1.0d0
2975 #else
2976       real(kind=8) :: scal_el=0.5d0
2977 #endif
2978 ! 12/13/98
2979 ! 13-go grudnia roku pamietnego...
2980       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2981                                              0.0d0,1.0d0,0.0d0,&
2982                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2983 !el local variables
2984       integer :: i,k,j
2985       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2986       real(kind=8) :: fac,t_eelecij,fracinbuf
2987
2988
2989 !d      write(iout,*) 'In EELEC'
2990 !        print *,"IN EELEC"
2991 !d      do i=1,nloctyp
2992 !d        write(iout,*) 'Type',i
2993 !d        write(iout,*) 'B1',B1(:,i)
2994 !d        write(iout,*) 'B2',B2(:,i)
2995 !d        write(iout,*) 'CC',CC(:,:,i)
2996 !d        write(iout,*) 'DD',DD(:,:,i)
2997 !d        write(iout,*) 'EE',EE(:,:,i)
2998 !d      enddo
2999 !d      call check_vecgrad
3000 !d      stop
3001 !      ees=0.0d0  !AS
3002 !      evdw1=0.0d0
3003 !      eel_loc=0.0d0
3004 !      eello_turn3=0.0d0
3005 !      eello_turn4=0.0d0
3006       t_eelecij=0.0d0
3007       ees=0.0D0
3008       evdw1=0.0D0
3009       eel_loc=0.0d0
3010       eello_turn3=0.0d0
3011       eello_turn4=0.0d0
3012 !
3013
3014       if (icheckgrad.eq.1) then
3015 !el
3016 !        do i=0,2*nres+2
3017 !          dc_norm(1,i)=0.0d0
3018 !          dc_norm(2,i)=0.0d0
3019 !          dc_norm(3,i)=0.0d0
3020 !        enddo
3021         do i=1,nres-1
3022           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3023           do k=1,3
3024             dc_norm(k,i)=dc(k,i)*fac
3025           enddo
3026 !          write (iout,*) 'i',i,' fac',fac
3027         enddo
3028       endif
3029 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3030 !        wturn6
3031       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3032           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3033           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3034 !        call vec_and_deriv
3035 #ifdef TIMING
3036         time01=MPI_Wtime()
3037 #endif
3038 !        print *, "before set matrices"
3039         call set_matrices
3040 !        print *, "after set matrices"
3041
3042 #ifdef TIMING
3043         time_mat=time_mat+MPI_Wtime()-time01
3044 #endif
3045       endif
3046 !       print *, "after set matrices"
3047 !d      do i=1,nres-1
3048 !d        write (iout,*) 'i=',i
3049 !d        do k=1,3
3050 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3051 !d        enddo
3052 !d        do k=1,3
3053 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3054 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3055 !d        enddo
3056 !d      enddo
3057       t_eelecij=0.0d0
3058       ees=0.0D0
3059       evdw1=0.0D0
3060       eel_loc=0.0d0
3061       eello_turn3=0.0d0
3062       eello_turn4=0.0d0
3063 !el      ind=0
3064       do i=1,nres
3065         num_cont_hb(i)=0
3066       enddo
3067 !d      print '(a)','Enter EELEC'
3068 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3069 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3070 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3071       do i=1,nres
3072         gel_loc_loc(i)=0.0d0
3073         gcorr_loc(i)=0.0d0
3074       enddo
3075 !
3076 !
3077 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3078 !
3079 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3080 !
3081
3082
3083 !        print *,"before iturn3 loop"
3084       do i=iturn3_start,iturn3_end
3085         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3086         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3087         dxi=dc(1,i)
3088         dyi=dc(2,i)
3089         dzi=dc(3,i)
3090         dx_normi=dc_norm(1,i)
3091         dy_normi=dc_norm(2,i)
3092         dz_normi=dc_norm(3,i)
3093         xmedi=c(1,i)+0.5d0*dxi
3094         ymedi=c(2,i)+0.5d0*dyi
3095         zmedi=c(3,i)+0.5d0*dzi
3096           xmedi=dmod(xmedi,boxxsize)
3097           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3098           ymedi=dmod(ymedi,boxysize)
3099           if (ymedi.lt.0) ymedi=ymedi+boxysize
3100           zmedi=dmod(zmedi,boxzsize)
3101           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3102         num_conti=0
3103        if ((zmedi.gt.bordlipbot) &
3104         .and.(zmedi.lt.bordliptop)) then
3105 !C the energy transfer exist
3106         if (zmedi.lt.buflipbot) then
3107 !C what fraction I am in
3108          fracinbuf=1.0d0- &
3109                ((zmedi-bordlipbot)/lipbufthick)
3110 !C lipbufthick is thickenes of lipid buffore
3111          sslipi=sscalelip(fracinbuf)
3112          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3113         elseif (zmedi.gt.bufliptop) then
3114          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3115          sslipi=sscalelip(fracinbuf)
3116          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3117         else
3118          sslipi=1.0d0
3119          ssgradlipi=0.0
3120         endif
3121        else
3122          sslipi=0.0d0
3123          ssgradlipi=0.0
3124        endif
3125 !       print *,i,sslipi,ssgradlipi
3126        call eelecij(i,i+2,ees,evdw1,eel_loc)
3127         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3128         num_cont_hb(i)=num_conti
3129       enddo
3130       do i=iturn4_start,iturn4_end
3131         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3132           .or. itype(i+3,1).eq.ntyp1 &
3133           .or. itype(i+4,1).eq.ntyp1) cycle
3134         dxi=dc(1,i)
3135         dyi=dc(2,i)
3136         dzi=dc(3,i)
3137         dx_normi=dc_norm(1,i)
3138         dy_normi=dc_norm(2,i)
3139         dz_normi=dc_norm(3,i)
3140         xmedi=c(1,i)+0.5d0*dxi
3141         ymedi=c(2,i)+0.5d0*dyi
3142         zmedi=c(3,i)+0.5d0*dzi
3143           xmedi=dmod(xmedi,boxxsize)
3144           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3145           ymedi=dmod(ymedi,boxysize)
3146           if (ymedi.lt.0) ymedi=ymedi+boxysize
3147           zmedi=dmod(zmedi,boxzsize)
3148           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3149        if ((zmedi.gt.bordlipbot)  &
3150        .and.(zmedi.lt.bordliptop)) then
3151 !C the energy transfer exist
3152         if (zmedi.lt.buflipbot) then
3153 !C what fraction I am in
3154          fracinbuf=1.0d0- &
3155              ((zmedi-bordlipbot)/lipbufthick)
3156 !C lipbufthick is thickenes of lipid buffore
3157          sslipi=sscalelip(fracinbuf)
3158          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3159         elseif (zmedi.gt.bufliptop) then
3160          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3161          sslipi=sscalelip(fracinbuf)
3162          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3163         else
3164          sslipi=1.0d0
3165          ssgradlipi=0.0
3166         endif
3167        else
3168          sslipi=0.0d0
3169          ssgradlipi=0.0
3170        endif
3171
3172         num_conti=num_cont_hb(i)
3173         call eelecij(i,i+3,ees,evdw1,eel_loc)
3174         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3175          call eturn4(i,eello_turn4)
3176         num_cont_hb(i)=num_conti
3177       enddo   ! i
3178 !
3179 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3180 !
3181 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3182       do i=iatel_s,iatel_e
3183         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3184         dxi=dc(1,i)
3185         dyi=dc(2,i)
3186         dzi=dc(3,i)
3187         dx_normi=dc_norm(1,i)
3188         dy_normi=dc_norm(2,i)
3189         dz_normi=dc_norm(3,i)
3190         xmedi=c(1,i)+0.5d0*dxi
3191         ymedi=c(2,i)+0.5d0*dyi
3192         zmedi=c(3,i)+0.5d0*dzi
3193           xmedi=dmod(xmedi,boxxsize)
3194           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3195           ymedi=dmod(ymedi,boxysize)
3196           if (ymedi.lt.0) ymedi=ymedi+boxysize
3197           zmedi=dmod(zmedi,boxzsize)
3198           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3199        if ((zmedi.gt.bordlipbot)  &
3200         .and.(zmedi.lt.bordliptop)) then
3201 !C the energy transfer exist
3202         if (zmedi.lt.buflipbot) then
3203 !C what fraction I am in
3204          fracinbuf=1.0d0- &
3205              ((zmedi-bordlipbot)/lipbufthick)
3206 !C lipbufthick is thickenes of lipid buffore
3207          sslipi=sscalelip(fracinbuf)
3208          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3209         elseif (zmedi.gt.bufliptop) then
3210          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3211          sslipi=sscalelip(fracinbuf)
3212          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3213         else
3214          sslipi=1.0d0
3215          ssgradlipi=0.0
3216         endif
3217        else
3218          sslipi=0.0d0
3219          ssgradlipi=0.0
3220        endif
3221
3222 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3223         num_conti=num_cont_hb(i)
3224         do j=ielstart(i),ielend(i)
3225 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3226           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3227           call eelecij(i,j,ees,evdw1,eel_loc)
3228         enddo ! j
3229         num_cont_hb(i)=num_conti
3230       enddo   ! i
3231 !      write (iout,*) "Number of loop steps in EELEC:",ind
3232 !d      do i=1,nres
3233 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3234 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3235 !d      enddo
3236 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3237 !cc      eel_loc=eel_loc+eello_turn3
3238 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3239       return
3240       end subroutine eelec
3241 !-----------------------------------------------------------------------------
3242       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3243
3244       use comm_locel
3245 !      implicit real*8 (a-h,o-z)
3246 !      include 'DIMENSIONS'
3247 #ifdef MPI
3248       include "mpif.h"
3249 #endif
3250 !      include 'COMMON.CONTROL'
3251 !      include 'COMMON.IOUNITS'
3252 !      include 'COMMON.GEO'
3253 !      include 'COMMON.VAR'
3254 !      include 'COMMON.LOCAL'
3255 !      include 'COMMON.CHAIN'
3256 !      include 'COMMON.DERIV'
3257 !      include 'COMMON.INTERACT'
3258 !      include 'COMMON.CONTACTS'
3259 !      include 'COMMON.TORSION'
3260 !      include 'COMMON.VECTORS'
3261 !      include 'COMMON.FFIELD'
3262 !      include 'COMMON.TIME1'
3263       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3264       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3265       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3266 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3267       real(kind=8),dimension(4) :: muij
3268       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3269                     dist_temp, dist_init,rlocshield,fracinbuf
3270       integer xshift,yshift,zshift,ilist,iresshield
3271 !el      integer :: num_conti,j1,j2
3272 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3273 !el        dz_normi,xmedi,ymedi,zmedi
3274
3275 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3276 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3277 !el          num_conti,j1,j2
3278
3279 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3280 #ifdef MOMENT
3281       real(kind=8) :: scal_el=1.0d0
3282 #else
3283       real(kind=8) :: scal_el=0.5d0
3284 #endif
3285 ! 12/13/98
3286 ! 13-go grudnia roku pamietnego...
3287       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3288                                              0.0d0,1.0d0,0.0d0,&
3289                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3290 !      integer :: maxconts=nres/4
3291 !el local variables
3292       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3293       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3294       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3295       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3296                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3297                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3298                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3299                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3300                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3301                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3302                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3303 !      maxconts=nres/4
3304 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3305 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3306
3307 !          time00=MPI_Wtime()
3308 !d      write (iout,*) "eelecij",i,j
3309 !          ind=ind+1
3310           iteli=itel(i)
3311           itelj=itel(j)
3312           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3313           aaa=app(iteli,itelj)
3314           bbb=bpp(iteli,itelj)
3315           ael6i=ael6(iteli,itelj)
3316           ael3i=ael3(iteli,itelj)
3317           dxj=dc(1,j)
3318           dyj=dc(2,j)
3319           dzj=dc(3,j)
3320           dx_normj=dc_norm(1,j)
3321           dy_normj=dc_norm(2,j)
3322           dz_normj=dc_norm(3,j)
3323 !          xj=c(1,j)+0.5D0*dxj-xmedi
3324 !          yj=c(2,j)+0.5D0*dyj-ymedi
3325 !          zj=c(3,j)+0.5D0*dzj-zmedi
3326           xj=c(1,j)+0.5D0*dxj
3327           yj=c(2,j)+0.5D0*dyj
3328           zj=c(3,j)+0.5D0*dzj
3329           xj=mod(xj,boxxsize)
3330           if (xj.lt.0) xj=xj+boxxsize
3331           yj=mod(yj,boxysize)
3332           if (yj.lt.0) yj=yj+boxysize
3333           zj=mod(zj,boxzsize)
3334           if (zj.lt.0) zj=zj+boxzsize
3335        if ((zj.gt.bordlipbot)  &
3336        .and.(zj.lt.bordliptop)) then
3337 !C the energy transfer exist
3338         if (zj.lt.buflipbot) then
3339 !C what fraction I am in
3340          fracinbuf=1.0d0-     &
3341              ((zj-bordlipbot)/lipbufthick)
3342 !C lipbufthick is thickenes of lipid buffore
3343          sslipj=sscalelip(fracinbuf)
3344          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3345         elseif (zj.gt.bufliptop) then
3346          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3347          sslipj=sscalelip(fracinbuf)
3348          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3349         else
3350          sslipj=1.0d0
3351          ssgradlipj=0.0
3352         endif
3353        else
3354          sslipj=0.0d0
3355          ssgradlipj=0.0
3356        endif
3357
3358       isubchap=0
3359       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3360       xj_safe=xj
3361       yj_safe=yj
3362       zj_safe=zj
3363       do xshift=-1,1
3364       do yshift=-1,1
3365       do zshift=-1,1
3366           xj=xj_safe+xshift*boxxsize
3367           yj=yj_safe+yshift*boxysize
3368           zj=zj_safe+zshift*boxzsize
3369           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3370           if(dist_temp.lt.dist_init) then
3371             dist_init=dist_temp
3372             xj_temp=xj
3373             yj_temp=yj
3374             zj_temp=zj
3375             isubchap=1
3376           endif
3377        enddo
3378        enddo
3379        enddo
3380        if (isubchap.eq.1) then
3381 !C          print *,i,j
3382           xj=xj_temp-xmedi
3383           yj=yj_temp-ymedi
3384           zj=zj_temp-zmedi
3385        else
3386           xj=xj_safe-xmedi
3387           yj=yj_safe-ymedi
3388           zj=zj_safe-zmedi
3389        endif
3390
3391           rij=xj*xj+yj*yj+zj*zj
3392           rrmij=1.0D0/rij
3393           rij=dsqrt(rij)
3394 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3395             sss_ele_cut=sscale_ele(rij)
3396             sss_ele_grad=sscagrad_ele(rij)
3397 !             sss_ele_cut=1.0d0
3398 !             sss_ele_grad=0.0d0
3399 !            print *,sss_ele_cut,sss_ele_grad,&
3400 !            (rij),r_cut_ele,rlamb_ele
3401 !            if (sss_ele_cut.le.0.0) go to 128
3402
3403           rmij=1.0D0/rij
3404           r3ij=rrmij*rmij
3405           r6ij=r3ij*r3ij
3406           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3407           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3408           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3409           fac=cosa-3.0D0*cosb*cosg
3410           ev1=aaa*r6ij*r6ij
3411 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3412           if (j.eq.i+2) ev1=scal_el*ev1
3413           ev2=bbb*r6ij
3414           fac3=ael6i*r6ij
3415           fac4=ael3i*r3ij
3416           evdwij=ev1+ev2
3417           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3418           el2=fac4*fac
3419 !          eesij=el1+el2
3420           if (shield_mode.gt.0) then
3421 !C          fac_shield(i)=0.4
3422 !C          fac_shield(j)=0.6
3423           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3424           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3425           eesij=(el1+el2)
3426           ees=ees+eesij*sss_ele_cut
3427 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3428 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3429           else
3430           fac_shield(i)=1.0
3431           fac_shield(j)=1.0
3432           eesij=(el1+el2)
3433           ees=ees+eesij   &
3434             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3435 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3436           endif
3437
3438 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3439           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3440 !          ees=ees+eesij*sss_ele_cut
3441           evdw1=evdw1+evdwij*sss_ele_cut  &
3442            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3443 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3444 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3445 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3446 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3447
3448           if (energy_dec) then
3449 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3450 !                  'evdw1',i,j,evdwij,&
3451 !                  iteli,itelj,aaa,evdw1
3452               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3453               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3454           endif
3455 !
3456 ! Calculate contributions to the Cartesian gradient.
3457 !
3458 #ifdef SPLITELE
3459           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3460               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3461           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3462              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3463           fac1=fac
3464           erij(1)=xj*rmij
3465           erij(2)=yj*rmij
3466           erij(3)=zj*rmij
3467 !
3468 ! Radial derivatives. First process both termini of the fragment (i,j)
3469 !
3470           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3471           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3472           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3473            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3474           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3475             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3476
3477           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3478           (shield_mode.gt.0)) then
3479 !C          print *,i,j
3480           do ilist=1,ishield_list(i)
3481            iresshield=shield_list(ilist,i)
3482            do k=1,3
3483            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3484            *2.0*sss_ele_cut
3485            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3486                    rlocshield &
3487             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3488             *sss_ele_cut
3489             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3490            enddo
3491           enddo
3492           do ilist=1,ishield_list(j)
3493            iresshield=shield_list(ilist,j)
3494            do k=1,3
3495            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3496           *2.0*sss_ele_cut
3497            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3498                    rlocshield &
3499            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3500            *sss_ele_cut
3501            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3502            enddo
3503           enddo
3504           do k=1,3
3505             gshieldc(k,i)=gshieldc(k,i)+ &
3506                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3507            *sss_ele_cut
3508
3509             gshieldc(k,j)=gshieldc(k,j)+ &
3510                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3511            *sss_ele_cut
3512
3513             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3514                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3515            *sss_ele_cut
3516
3517             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3518                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3519            *sss_ele_cut
3520
3521            enddo
3522            endif
3523
3524
3525 !          do k=1,3
3526 !            ghalf=0.5D0*ggg(k)
3527 !            gelc(k,i)=gelc(k,i)+ghalf
3528 !            gelc(k,j)=gelc(k,j)+ghalf
3529 !          enddo
3530 ! 9/28/08 AL Gradient compotents will be summed only at the end
3531           do k=1,3
3532             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3533             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3534           enddo
3535             gelc_long(3,j)=gelc_long(3,j)+  &
3536           ssgradlipj*eesij/2.0d0*lipscale**2&
3537            *sss_ele_cut
3538
3539             gelc_long(3,i)=gelc_long(3,i)+  &
3540           ssgradlipi*eesij/2.0d0*lipscale**2&
3541            *sss_ele_cut
3542
3543
3544 !
3545 ! Loop over residues i+1 thru j-1.
3546 !
3547 !grad          do k=i+1,j-1
3548 !grad            do l=1,3
3549 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3550 !grad            enddo
3551 !grad          enddo
3552           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3553            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3554           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3555            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3556           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3557            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3558
3559 !          do k=1,3
3560 !            ghalf=0.5D0*ggg(k)
3561 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3562 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3563 !          enddo
3564 ! 9/28/08 AL Gradient compotents will be summed only at the end
3565           do k=1,3
3566             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3567             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3568           enddo
3569
3570 !C Lipidic part for scaling weight
3571            gvdwpp(3,j)=gvdwpp(3,j)+ &
3572           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3573            gvdwpp(3,i)=gvdwpp(3,i)+ &
3574           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3575 !! Loop over residues i+1 thru j-1.
3576 !
3577 !grad          do k=i+1,j-1
3578 !grad            do l=1,3
3579 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3580 !grad            enddo
3581 !grad          enddo
3582 #else
3583           facvdw=(ev1+evdwij)*sss_ele_cut &
3584            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3585
3586           facel=(el1+eesij)*sss_ele_cut
3587           fac1=fac
3588           fac=-3*rrmij*(facvdw+facvdw+facel)
3589           erij(1)=xj*rmij
3590           erij(2)=yj*rmij
3591           erij(3)=zj*rmij
3592 !
3593 ! Radial derivatives. First process both termini of the fragment (i,j)
3594 !
3595           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3596           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3597           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3598 !          do k=1,3
3599 !            ghalf=0.5D0*ggg(k)
3600 !            gelc(k,i)=gelc(k,i)+ghalf
3601 !            gelc(k,j)=gelc(k,j)+ghalf
3602 !          enddo
3603 ! 9/28/08 AL Gradient compotents will be summed only at the end
3604           do k=1,3
3605             gelc_long(k,j)=gelc(k,j)+ggg(k)
3606             gelc_long(k,i)=gelc(k,i)-ggg(k)
3607           enddo
3608 !
3609 ! Loop over residues i+1 thru j-1.
3610 !
3611 !grad          do k=i+1,j-1
3612 !grad            do l=1,3
3613 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3614 !grad            enddo
3615 !grad          enddo
3616 ! 9/28/08 AL Gradient compotents will be summed only at the end
3617           ggg(1)=facvdw*xj &
3618            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3619           ggg(2)=facvdw*yj &
3620            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3621           ggg(3)=facvdw*zj &
3622            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3623
3624           do k=1,3
3625             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3626             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3627           enddo
3628            gvdwpp(3,j)=gvdwpp(3,j)+ &
3629           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3630            gvdwpp(3,i)=gvdwpp(3,i)+ &
3631           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3632
3633 #endif
3634 !
3635 ! Angular part
3636 !
3637           ecosa=2.0D0*fac3*fac1+fac4
3638           fac4=-3.0D0*fac4
3639           fac3=-6.0D0*fac3
3640           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3641           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3642           do k=1,3
3643             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3644             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3645           enddo
3646 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3647 !d   &          (dcosg(k),k=1,3)
3648           do k=1,3
3649             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3650              *fac_shield(i)**2*fac_shield(j)**2 &
3651              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3652
3653           enddo
3654 !          do k=1,3
3655 !            ghalf=0.5D0*ggg(k)
3656 !            gelc(k,i)=gelc(k,i)+ghalf
3657 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3658 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3659 !            gelc(k,j)=gelc(k,j)+ghalf
3660 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3661 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3662 !          enddo
3663 !grad          do k=i+1,j-1
3664 !grad            do l=1,3
3665 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3666 !grad            enddo
3667 !grad          enddo
3668           do k=1,3
3669             gelc(k,i)=gelc(k,i) &
3670                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3671                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3672                      *sss_ele_cut &
3673                      *fac_shield(i)**2*fac_shield(j)**2 &
3674                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3675
3676             gelc(k,j)=gelc(k,j) &
3677                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3678                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3679                      *sss_ele_cut  &
3680                      *fac_shield(i)**2*fac_shield(j)**2  &
3681                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3682
3683             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3684             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3685           enddo
3686
3687           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3688               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3689               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3690 !
3691 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3692 !   energy of a peptide unit is assumed in the form of a second-order
3693 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3694 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3695 !   are computed for EVERY pair of non-contiguous peptide groups.
3696 !
3697           if (j.lt.nres-1) then
3698             j1=j+1
3699             j2=j-1
3700           else
3701             j1=j-1
3702             j2=j-2
3703           endif
3704           kkk=0
3705           do k=1,2
3706             do l=1,2
3707               kkk=kkk+1
3708               muij(kkk)=mu(k,i)*mu(l,j)
3709             enddo
3710           enddo
3711 !d         write (iout,*) 'EELEC: i',i,' j',j
3712 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3713 !d          write(iout,*) 'muij',muij
3714           ury=scalar(uy(1,i),erij)
3715           urz=scalar(uz(1,i),erij)
3716           vry=scalar(uy(1,j),erij)
3717           vrz=scalar(uz(1,j),erij)
3718           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3719           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3720           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3721           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3722           fac=dsqrt(-ael6i)*r3ij
3723           a22=a22*fac
3724           a23=a23*fac
3725           a32=a32*fac
3726           a33=a33*fac
3727 !d          write (iout,'(4i5,4f10.5)')
3728 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3729 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3730 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3731 !d     &      uy(:,j),uz(:,j)
3732 !d          write (iout,'(4f10.5)')
3733 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3734 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3735 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3736 !d           write (iout,'(9f10.5/)')
3737 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3738 ! Derivatives of the elements of A in virtual-bond vectors
3739           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3740           do k=1,3
3741             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3742             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3743             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3744             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3745             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3746             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3747             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3748             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3749             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3750             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3751             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3752             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3753           enddo
3754 ! Compute radial contributions to the gradient
3755           facr=-3.0d0*rrmij
3756           a22der=a22*facr
3757           a23der=a23*facr
3758           a32der=a32*facr
3759           a33der=a33*facr
3760           agg(1,1)=a22der*xj
3761           agg(2,1)=a22der*yj
3762           agg(3,1)=a22der*zj
3763           agg(1,2)=a23der*xj
3764           agg(2,2)=a23der*yj
3765           agg(3,2)=a23der*zj
3766           agg(1,3)=a32der*xj
3767           agg(2,3)=a32der*yj
3768           agg(3,3)=a32der*zj
3769           agg(1,4)=a33der*xj
3770           agg(2,4)=a33der*yj
3771           agg(3,4)=a33der*zj
3772 ! Add the contributions coming from er
3773           fac3=-3.0d0*fac
3774           do k=1,3
3775             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3776             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3777             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3778             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3779           enddo
3780           do k=1,3
3781 ! Derivatives in DC(i)
3782 !grad            ghalf1=0.5d0*agg(k,1)
3783 !grad            ghalf2=0.5d0*agg(k,2)
3784 !grad            ghalf3=0.5d0*agg(k,3)
3785 !grad            ghalf4=0.5d0*agg(k,4)
3786             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3787             -3.0d0*uryg(k,2)*vry)!+ghalf1
3788             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3789             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3790             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3791             -3.0d0*urzg(k,2)*vry)!+ghalf3
3792             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3793             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3794 ! Derivatives in DC(i+1)
3795             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3796             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3797             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3798             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3799             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3800             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3801             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3802             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3803 ! Derivatives in DC(j)
3804             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3805             -3.0d0*vryg(k,2)*ury)!+ghalf1
3806             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3807             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3808             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3809             -3.0d0*vryg(k,2)*urz)!+ghalf3
3810             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3811             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3812 ! Derivatives in DC(j+1) or DC(nres-1)
3813             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3814             -3.0d0*vryg(k,3)*ury)
3815             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3816             -3.0d0*vrzg(k,3)*ury)
3817             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3818             -3.0d0*vryg(k,3)*urz)
3819             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3820             -3.0d0*vrzg(k,3)*urz)
3821 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3822 !grad              do l=1,4
3823 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3824 !grad              enddo
3825 !grad            endif
3826           enddo
3827           acipa(1,1)=a22
3828           acipa(1,2)=a23
3829           acipa(2,1)=a32
3830           acipa(2,2)=a33
3831           a22=-a22
3832           a23=-a23
3833           do l=1,2
3834             do k=1,3
3835               agg(k,l)=-agg(k,l)
3836               aggi(k,l)=-aggi(k,l)
3837               aggi1(k,l)=-aggi1(k,l)
3838               aggj(k,l)=-aggj(k,l)
3839               aggj1(k,l)=-aggj1(k,l)
3840             enddo
3841           enddo
3842           if (j.lt.nres-1) then
3843             a22=-a22
3844             a32=-a32
3845             do l=1,3,2
3846               do k=1,3
3847                 agg(k,l)=-agg(k,l)
3848                 aggi(k,l)=-aggi(k,l)
3849                 aggi1(k,l)=-aggi1(k,l)
3850                 aggj(k,l)=-aggj(k,l)
3851                 aggj1(k,l)=-aggj1(k,l)
3852               enddo
3853             enddo
3854           else
3855             a22=-a22
3856             a23=-a23
3857             a32=-a32
3858             a33=-a33
3859             do l=1,4
3860               do k=1,3
3861                 agg(k,l)=-agg(k,l)
3862                 aggi(k,l)=-aggi(k,l)
3863                 aggi1(k,l)=-aggi1(k,l)
3864                 aggj(k,l)=-aggj(k,l)
3865                 aggj1(k,l)=-aggj1(k,l)
3866               enddo
3867             enddo
3868           endif
3869           ENDIF ! WCORR
3870           IF (wel_loc.gt.0.0d0) THEN
3871 ! Contribution to the local-electrostatic energy coming from the i-j pair
3872           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3873            +a33*muij(4)
3874           if (shield_mode.eq.0) then
3875            fac_shield(i)=1.0
3876            fac_shield(j)=1.0
3877           endif
3878           eel_loc_ij=eel_loc_ij &
3879          *fac_shield(i)*fac_shield(j) &
3880          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3881 !C Now derivative over eel_loc
3882           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3883          (shield_mode.gt.0)) then
3884 !C          print *,i,j
3885
3886           do ilist=1,ishield_list(i)
3887            iresshield=shield_list(ilist,i)
3888            do k=1,3
3889            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3890                                                 /fac_shield(i)&
3891            *sss_ele_cut
3892            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3893                    rlocshield  &
3894           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3895           *sss_ele_cut
3896
3897             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3898            +rlocshield
3899            enddo
3900           enddo
3901           do ilist=1,ishield_list(j)
3902            iresshield=shield_list(ilist,j)
3903            do k=1,3
3904            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3905                                             /fac_shield(j)   &
3906             *sss_ele_cut
3907            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3908                    rlocshield  &
3909       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3910        *sss_ele_cut
3911
3912            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3913                   +rlocshield
3914
3915            enddo
3916           enddo
3917
3918           do k=1,3
3919             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3920                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3921                     *sss_ele_cut
3922             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3923                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3924                     *sss_ele_cut
3925             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3926                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3927                     *sss_ele_cut
3928             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3929                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3930                     *sss_ele_cut
3931
3932            enddo
3933            endif
3934
3935
3936 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3937 !           eel_loc_ij=0.0
3938           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3939                   'eelloc',i,j,eel_loc_ij
3940 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3941 !          if (energy_dec) write (iout,*) "muij",muij
3942 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3943
3944           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3945 ! Partial derivatives in virtual-bond dihedral angles gamma
3946           if (i.gt.1) &
3947           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3948                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3949                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3950                  *sss_ele_cut  &
3951           *fac_shield(i)*fac_shield(j) &
3952           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3953
3954           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3955                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3956                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3957                  *sss_ele_cut &
3958           *fac_shield(i)*fac_shield(j) &
3959           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3960 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3961 !          do l=1,3
3962 !            ggg(1)=(agg(1,1)*muij(1)+ &
3963 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3964 !            *sss_ele_cut &
3965 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3966 !            ggg(2)=(agg(2,1)*muij(1)+ &
3967 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3968 !            *sss_ele_cut &
3969 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3970 !            ggg(3)=(agg(3,1)*muij(1)+ &
3971 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3972 !            *sss_ele_cut &
3973 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3974            xtemp(1)=xj
3975            xtemp(2)=yj
3976            xtemp(3)=zj
3977
3978            do l=1,3
3979             ggg(l)=(agg(l,1)*muij(1)+ &
3980                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3981             *sss_ele_cut &
3982           *fac_shield(i)*fac_shield(j) &
3983           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3984              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3985
3986
3987             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3988             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3989 !grad            ghalf=0.5d0*ggg(l)
3990 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3991 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3992           enddo
3993             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3994           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3995           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3996
3997             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3998           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3999           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4000
4001 !grad          do k=i+1,j2
4002 !grad            do l=1,3
4003 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4004 !grad            enddo
4005 !grad          enddo
4006 ! Remaining derivatives of eello
4007           do l=1,3
4008             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4009                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4010             *sss_ele_cut &
4011           *fac_shield(i)*fac_shield(j) &
4012           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4013
4014 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4015             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4016                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4017             +aggi1(l,4)*muij(4))&
4018             *sss_ele_cut &
4019           *fac_shield(i)*fac_shield(j) &
4020           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4021
4022 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4023             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4024                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4025             *sss_ele_cut &
4026           *fac_shield(i)*fac_shield(j) &
4027           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4028
4029 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4030             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4031                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4032             +aggj1(l,4)*muij(4))&
4033             *sss_ele_cut &
4034           *fac_shield(i)*fac_shield(j) &
4035           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4036
4037 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4038           enddo
4039           ENDIF
4040 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4041 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4042           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4043              .and. num_conti.le.maxconts) then
4044 !            write (iout,*) i,j," entered corr"
4045 !
4046 ! Calculate the contact function. The ith column of the array JCONT will
4047 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4048 ! greater than I). The arrays FACONT and GACONT will contain the values of
4049 ! the contact function and its derivative.
4050 !           r0ij=1.02D0*rpp(iteli,itelj)
4051 !           r0ij=1.11D0*rpp(iteli,itelj)
4052             r0ij=2.20D0*rpp(iteli,itelj)
4053 !           r0ij=1.55D0*rpp(iteli,itelj)
4054             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4055 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4056             if (fcont.gt.0.0D0) then
4057               num_conti=num_conti+1
4058               if (num_conti.gt.maxconts) then
4059 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4060 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4061                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4062                                ' will skip next contacts for this conf.', num_conti
4063               else
4064                 jcont_hb(num_conti,i)=j
4065 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4066 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4067                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4068                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4069 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4070 !  terms.
4071                 d_cont(num_conti,i)=rij
4072 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4073 !     --- Electrostatic-interaction matrix ---
4074                 a_chuj(1,1,num_conti,i)=a22
4075                 a_chuj(1,2,num_conti,i)=a23
4076                 a_chuj(2,1,num_conti,i)=a32
4077                 a_chuj(2,2,num_conti,i)=a33
4078 !     --- Gradient of rij
4079                 do kkk=1,3
4080                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4081                 enddo
4082                 kkll=0
4083                 do k=1,2
4084                   do l=1,2
4085                     kkll=kkll+1
4086                     do m=1,3
4087                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4088                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4089                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4090                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4091                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4092                     enddo
4093                   enddo
4094                 enddo
4095                 ENDIF
4096                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4097 ! Calculate contact energies
4098                 cosa4=4.0D0*cosa
4099                 wij=cosa-3.0D0*cosb*cosg
4100                 cosbg1=cosb+cosg
4101                 cosbg2=cosb-cosg
4102 !               fac3=dsqrt(-ael6i)/r0ij**3
4103                 fac3=dsqrt(-ael6i)*r3ij
4104 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4105                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4106                 if (ees0tmp.gt.0) then
4107                   ees0pij=dsqrt(ees0tmp)
4108                 else
4109                   ees0pij=0
4110                 endif
4111                 if (shield_mode.eq.0) then
4112                 fac_shield(i)=1.0d0
4113                 fac_shield(j)=1.0d0
4114                 else
4115                 ees0plist(num_conti,i)=j
4116                 endif
4117 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4118                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4119                 if (ees0tmp.gt.0) then
4120                   ees0mij=dsqrt(ees0tmp)
4121                 else
4122                   ees0mij=0
4123                 endif
4124 !               ees0mij=0.0D0
4125                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4126                      *sss_ele_cut &
4127                      *fac_shield(i)*fac_shield(j)
4128
4129                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4130                      *sss_ele_cut &
4131                      *fac_shield(i)*fac_shield(j)
4132
4133 ! Diagnostics. Comment out or remove after debugging!
4134 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4135 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4136 !               ees0m(num_conti,i)=0.0D0
4137 ! End diagnostics.
4138 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4139 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4140 ! Angular derivatives of the contact function
4141                 ees0pij1=fac3/ees0pij
4142                 ees0mij1=fac3/ees0mij
4143                 fac3p=-3.0D0*fac3*rrmij
4144                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4145                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4146 !               ees0mij1=0.0D0
4147                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4148                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4149                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4150                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4151                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4152                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4153                 ecosap=ecosa1+ecosa2
4154                 ecosbp=ecosb1+ecosb2
4155                 ecosgp=ecosg1+ecosg2
4156                 ecosam=ecosa1-ecosa2
4157                 ecosbm=ecosb1-ecosb2
4158                 ecosgm=ecosg1-ecosg2
4159 ! Diagnostics
4160 !               ecosap=ecosa1
4161 !               ecosbp=ecosb1
4162 !               ecosgp=ecosg1
4163 !               ecosam=0.0D0
4164 !               ecosbm=0.0D0
4165 !               ecosgm=0.0D0
4166 ! End diagnostics
4167                 facont_hb(num_conti,i)=fcont
4168                 fprimcont=fprimcont/rij
4169 !d              facont_hb(num_conti,i)=1.0D0
4170 ! Following line is for diagnostics.
4171 !d              fprimcont=0.0D0
4172                 do k=1,3
4173                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4174                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4175                 enddo
4176                 do k=1,3
4177                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4178                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4179                 enddo
4180                 gggp(1)=gggp(1)+ees0pijp*xj &
4181                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4182                 gggp(2)=gggp(2)+ees0pijp*yj &
4183                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4184                 gggp(3)=gggp(3)+ees0pijp*zj &
4185                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4186
4187                 gggm(1)=gggm(1)+ees0mijp*xj &
4188                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4189
4190                 gggm(2)=gggm(2)+ees0mijp*yj &
4191                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4192
4193                 gggm(3)=gggm(3)+ees0mijp*zj &
4194                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4195
4196 ! Derivatives due to the contact function
4197                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4198                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4199                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4200                 do k=1,3
4201 !
4202 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4203 !          following the change of gradient-summation algorithm.
4204 !
4205 !grad                  ghalfp=0.5D0*gggp(k)
4206 !grad                  ghalfm=0.5D0*gggm(k)
4207                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4208                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4209                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4210                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4211
4212                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4213                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4214                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4215                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4216
4217                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4218                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4219
4220                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4221                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4222                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4223                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4224
4225                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4226                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4227                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4228                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4229
4230                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4231                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4232
4233                 enddo
4234 ! Diagnostics. Comment out or remove after debugging!
4235 !diag           do k=1,3
4236 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4237 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4238 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4239 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4240 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4241 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4242 !diag           enddo
4243               ENDIF ! wcorr
4244               endif  ! num_conti.le.maxconts
4245             endif  ! fcont.gt.0
4246           endif    ! j.gt.i+1
4247           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4248             do k=1,4
4249               do l=1,3
4250                 ghalf=0.5d0*agg(l,k)
4251                 aggi(l,k)=aggi(l,k)+ghalf
4252                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4253                 aggj(l,k)=aggj(l,k)+ghalf
4254               enddo
4255             enddo
4256             if (j.eq.nres-1 .and. i.lt.j-2) then
4257               do k=1,4
4258                 do l=1,3
4259                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4260                 enddo
4261               enddo
4262             endif
4263           endif
4264  128  continue
4265 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4266       return
4267       end subroutine eelecij
4268 !-----------------------------------------------------------------------------
4269       subroutine eturn3(i,eello_turn3)
4270 ! Third- and fourth-order contributions from turns
4271
4272       use comm_locel
4273 !      implicit real*8 (a-h,o-z)
4274 !      include 'DIMENSIONS'
4275 !      include 'COMMON.IOUNITS'
4276 !      include 'COMMON.GEO'
4277 !      include 'COMMON.VAR'
4278 !      include 'COMMON.LOCAL'
4279 !      include 'COMMON.CHAIN'
4280 !      include 'COMMON.DERIV'
4281 !      include 'COMMON.INTERACT'
4282 !      include 'COMMON.CONTACTS'
4283 !      include 'COMMON.TORSION'
4284 !      include 'COMMON.VECTORS'
4285 !      include 'COMMON.FFIELD'
4286 !      include 'COMMON.CONTROL'
4287       real(kind=8),dimension(3) :: ggg
4288       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4289         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4290       real(kind=8),dimension(2) :: auxvec,auxvec1
4291 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4292       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4293 !el      integer :: num_conti,j1,j2
4294 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4295 !el        dz_normi,xmedi,ymedi,zmedi
4296
4297 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4298 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4299 !el         num_conti,j1,j2
4300 !el local variables
4301       integer :: i,j,l,k,ilist,iresshield
4302       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4303
4304       j=i+2
4305 !      write (iout,*) "eturn3",i,j,j1,j2
4306           zj=(c(3,j)+c(3,j+1))/2.0d0
4307           zj=mod(zj,boxzsize)
4308           if (zj.lt.0) zj=zj+boxzsize
4309           if ((zj.lt.0)) write (*,*) "CHUJ"
4310        if ((zj.gt.bordlipbot)  &
4311         .and.(zj.lt.bordliptop)) then
4312 !C the energy transfer exist
4313         if (zj.lt.buflipbot) then
4314 !C what fraction I am in
4315          fracinbuf=1.0d0-     &
4316              ((zj-bordlipbot)/lipbufthick)
4317 !C lipbufthick is thickenes of lipid buffore
4318          sslipj=sscalelip(fracinbuf)
4319          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4320         elseif (zj.gt.bufliptop) then
4321          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4322          sslipj=sscalelip(fracinbuf)
4323          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4324         else
4325          sslipj=1.0d0
4326          ssgradlipj=0.0
4327         endif
4328        else
4329          sslipj=0.0d0
4330          ssgradlipj=0.0
4331        endif
4332
4333       a_temp(1,1)=a22
4334       a_temp(1,2)=a23
4335       a_temp(2,1)=a32
4336       a_temp(2,2)=a33
4337 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4338 !
4339 !               Third-order contributions
4340 !
4341 !                 (i+2)o----(i+3)
4342 !                      | |
4343 !                      | |
4344 !                 (i+1)o----i
4345 !
4346 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4347 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4348         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4349         call transpose2(auxmat(1,1),auxmat1(1,1))
4350         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4351         if (shield_mode.eq.0) then
4352         fac_shield(i)=1.0d0
4353         fac_shield(j)=1.0d0
4354         endif
4355
4356         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4357          *fac_shield(i)*fac_shield(j)  &
4358          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4359         eello_t3= &
4360         0.5d0*(pizda(1,1)+pizda(2,2)) &
4361         *fac_shield(i)*fac_shield(j)
4362
4363         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4364                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4365           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4366        (shield_mode.gt.0)) then
4367 !C          print *,i,j
4368
4369           do ilist=1,ishield_list(i)
4370            iresshield=shield_list(ilist,i)
4371            do k=1,3
4372            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4373            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4374                    rlocshield &
4375            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4376             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4377              +rlocshield
4378            enddo
4379           enddo
4380           do ilist=1,ishield_list(j)
4381            iresshield=shield_list(ilist,j)
4382            do k=1,3
4383            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4384            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4385                    rlocshield &
4386            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4387            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4388                   +rlocshield
4389
4390            enddo
4391           enddo
4392
4393           do k=1,3
4394             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4395                    grad_shield(k,i)*eello_t3/fac_shield(i)
4396             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4397                    grad_shield(k,j)*eello_t3/fac_shield(j)
4398             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4399                    grad_shield(k,i)*eello_t3/fac_shield(i)
4400             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4401                    grad_shield(k,j)*eello_t3/fac_shield(j)
4402            enddo
4403            endif
4404
4405 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4406 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4407 !d     &    ' eello_turn3_num',4*eello_turn3_num
4408 ! Derivatives in gamma(i)
4409         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4410         call transpose2(auxmat2(1,1),auxmat3(1,1))
4411         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4412         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4413           *fac_shield(i)*fac_shield(j)        &
4414           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4415 ! Derivatives in gamma(i+1)
4416         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4417         call transpose2(auxmat2(1,1),auxmat3(1,1))
4418         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4419         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4420           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4421           *fac_shield(i)*fac_shield(j)        &
4422           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4423
4424 ! Cartesian derivatives
4425         do l=1,3
4426 !            ghalf1=0.5d0*agg(l,1)
4427 !            ghalf2=0.5d0*agg(l,2)
4428 !            ghalf3=0.5d0*agg(l,3)
4429 !            ghalf4=0.5d0*agg(l,4)
4430           a_temp(1,1)=aggi(l,1)!+ghalf1
4431           a_temp(1,2)=aggi(l,2)!+ghalf2
4432           a_temp(2,1)=aggi(l,3)!+ghalf3
4433           a_temp(2,2)=aggi(l,4)!+ghalf4
4434           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4435           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4436             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4437           *fac_shield(i)*fac_shield(j)      &
4438           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4439
4440           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4441           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4442           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4443           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4444           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4445           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4446             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4447           *fac_shield(i)*fac_shield(j)        &
4448           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4449
4450           a_temp(1,1)=aggj(l,1)!+ghalf1
4451           a_temp(1,2)=aggj(l,2)!+ghalf2
4452           a_temp(2,1)=aggj(l,3)!+ghalf3
4453           a_temp(2,2)=aggj(l,4)!+ghalf4
4454           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4455           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4456             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4457           *fac_shield(i)*fac_shield(j)      &
4458           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4459
4460           a_temp(1,1)=aggj1(l,1)
4461           a_temp(1,2)=aggj1(l,2)
4462           a_temp(2,1)=aggj1(l,3)
4463           a_temp(2,2)=aggj1(l,4)
4464           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4465           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4466             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4467           *fac_shield(i)*fac_shield(j)        &
4468           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4469         enddo
4470          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4471           ssgradlipi*eello_t3/4.0d0*lipscale
4472          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4473           ssgradlipj*eello_t3/4.0d0*lipscale
4474          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4475           ssgradlipi*eello_t3/4.0d0*lipscale
4476          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4477           ssgradlipj*eello_t3/4.0d0*lipscale
4478
4479       return
4480       end subroutine eturn3
4481 !-----------------------------------------------------------------------------
4482       subroutine eturn4(i,eello_turn4)
4483 ! Third- and fourth-order contributions from turns
4484
4485       use comm_locel
4486 !      implicit real*8 (a-h,o-z)
4487 !      include 'DIMENSIONS'
4488 !      include 'COMMON.IOUNITS'
4489 !      include 'COMMON.GEO'
4490 !      include 'COMMON.VAR'
4491 !      include 'COMMON.LOCAL'
4492 !      include 'COMMON.CHAIN'
4493 !      include 'COMMON.DERIV'
4494 !      include 'COMMON.INTERACT'
4495 !      include 'COMMON.CONTACTS'
4496 !      include 'COMMON.TORSION'
4497 !      include 'COMMON.VECTORS'
4498 !      include 'COMMON.FFIELD'
4499 !      include 'COMMON.CONTROL'
4500       real(kind=8),dimension(3) :: ggg
4501       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4502         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4503       real(kind=8),dimension(2) :: auxvec,auxvec1
4504 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4505       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4506 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4507 !el        dz_normi,xmedi,ymedi,zmedi
4508 !el      integer :: num_conti,j1,j2
4509 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4510 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4511 !el          num_conti,j1,j2
4512 !el local variables
4513       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4514       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4515          rlocshield
4516
4517       j=i+3
4518 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4519 !
4520 !               Fourth-order contributions
4521 !
4522 !                 (i+3)o----(i+4)
4523 !                     /  |
4524 !               (i+2)o   |
4525 !                     \  |
4526 !                 (i+1)o----i
4527 !
4528 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4529 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4530 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4531           zj=(c(3,j)+c(3,j+1))/2.0d0
4532           zj=mod(zj,boxzsize)
4533           if (zj.lt.0) zj=zj+boxzsize
4534        if ((zj.gt.bordlipbot)  &
4535         .and.(zj.lt.bordliptop)) then
4536 !C the energy transfer exist
4537         if (zj.lt.buflipbot) then
4538 !C what fraction I am in
4539          fracinbuf=1.0d0-     &
4540              ((zj-bordlipbot)/lipbufthick)
4541 !C lipbufthick is thickenes of lipid buffore
4542          sslipj=sscalelip(fracinbuf)
4543          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4544         elseif (zj.gt.bufliptop) then
4545          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4546          sslipj=sscalelip(fracinbuf)
4547          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4548         else
4549          sslipj=1.0d0
4550          ssgradlipj=0.0
4551         endif
4552        else
4553          sslipj=0.0d0
4554          ssgradlipj=0.0
4555        endif
4556
4557         a_temp(1,1)=a22
4558         a_temp(1,2)=a23
4559         a_temp(2,1)=a32
4560         a_temp(2,2)=a33
4561         iti1=itortyp(itype(i+1,1))
4562         iti2=itortyp(itype(i+2,1))
4563         iti3=itortyp(itype(i+3,1))
4564 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4565         call transpose2(EUg(1,1,i+1),e1t(1,1))
4566         call transpose2(Eug(1,1,i+2),e2t(1,1))
4567         call transpose2(Eug(1,1,i+3),e3t(1,1))
4568         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4569         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4570         s1=scalar2(b1(1,iti2),auxvec(1))
4571         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4572         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4573         s2=scalar2(b1(1,iti1),auxvec(1))
4574         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4575         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4576         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4577         if (shield_mode.eq.0) then
4578         fac_shield(i)=1.0
4579         fac_shield(j)=1.0
4580         endif
4581
4582         eello_turn4=eello_turn4-(s1+s2+s3) &
4583         *fac_shield(i)*fac_shield(j)       &
4584         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4585         eello_t4=-(s1+s2+s3)  &
4586           *fac_shield(i)*fac_shield(j)
4587 !C Now derivative over shield:
4588           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4589          (shield_mode.gt.0)) then
4590 !C          print *,i,j
4591
4592           do ilist=1,ishield_list(i)
4593            iresshield=shield_list(ilist,i)
4594            do k=1,3
4595            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4596            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4597                    rlocshield &
4598             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4599             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4600            +rlocshield
4601            enddo
4602           enddo
4603           do ilist=1,ishield_list(j)
4604            iresshield=shield_list(ilist,j)
4605            do k=1,3
4606            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4607            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4608                    rlocshield  &
4609            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4610            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4611                   +rlocshield
4612
4613            enddo
4614           enddo
4615
4616           do k=1,3
4617             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4618                    grad_shield(k,i)*eello_t4/fac_shield(i)
4619             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4620                    grad_shield(k,j)*eello_t4/fac_shield(j)
4621             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4622                    grad_shield(k,i)*eello_t4/fac_shield(i)
4623             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4624                    grad_shield(k,j)*eello_t4/fac_shield(j)
4625            enddo
4626            endif
4627
4628         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4629            'eturn4',i,j,-(s1+s2+s3)
4630 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4631 !d     &    ' eello_turn4_num',8*eello_turn4_num
4632 ! Derivatives in gamma(i)
4633         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4634         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4635         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4636         s1=scalar2(b1(1,iti2),auxvec(1))
4637         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4638         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4639         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4640        *fac_shield(i)*fac_shield(j)  &
4641        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4642
4643 ! Derivatives in gamma(i+1)
4644         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4645         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4646         s2=scalar2(b1(1,iti1),auxvec(1))
4647         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4648         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4649         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4650         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4651        *fac_shield(i)*fac_shield(j)  &
4652        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4653
4654 ! Derivatives in gamma(i+2)
4655         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4656         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4657         s1=scalar2(b1(1,iti2),auxvec(1))
4658         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4659         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4660         s2=scalar2(b1(1,iti1),auxvec(1))
4661         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4662         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4663         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4664         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4665        *fac_shield(i)*fac_shield(j)  &
4666        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4667
4668 ! Cartesian derivatives
4669 ! Derivatives of this turn contributions in DC(i+2)
4670         if (j.lt.nres-1) then
4671           do l=1,3
4672             a_temp(1,1)=agg(l,1)
4673             a_temp(1,2)=agg(l,2)
4674             a_temp(2,1)=agg(l,3)
4675             a_temp(2,2)=agg(l,4)
4676             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4677             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4678             s1=scalar2(b1(1,iti2),auxvec(1))
4679             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4680             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4681             s2=scalar2(b1(1,iti1),auxvec(1))
4682             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4683             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4684             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4685             ggg(l)=-(s1+s2+s3)
4686             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4687        *fac_shield(i)*fac_shield(j)  &
4688        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4689
4690           enddo
4691         endif
4692 ! Remaining derivatives of this turn contribution
4693         do l=1,3
4694           a_temp(1,1)=aggi(l,1)
4695           a_temp(1,2)=aggi(l,2)
4696           a_temp(2,1)=aggi(l,3)
4697           a_temp(2,2)=aggi(l,4)
4698           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4699           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4700           s1=scalar2(b1(1,iti2),auxvec(1))
4701           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4702           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4703           s2=scalar2(b1(1,iti1),auxvec(1))
4704           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4705           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4706           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4707           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4708          *fac_shield(i)*fac_shield(j)  &
4709          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4710
4711
4712           a_temp(1,1)=aggi1(l,1)
4713           a_temp(1,2)=aggi1(l,2)
4714           a_temp(2,1)=aggi1(l,3)
4715           a_temp(2,2)=aggi1(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+1)=gcorr4_turn(l,i+1)-(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)=aggj(l,1)
4731           a_temp(1,2)=aggj(l,2)
4732           a_temp(2,1)=aggj(l,3)
4733           a_temp(2,2)=aggj(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,j)=gcorr4_turn(l,j)-(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)=aggj1(l,1)
4749           a_temp(1,2)=aggj1(l,2)
4750           a_temp(2,1)=aggj1(l,3)
4751           a_temp(2,2)=aggj1(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 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4762           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4763          *fac_shield(i)*fac_shield(j)  &
4764          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4765
4766         enddo
4767          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4768           ssgradlipi*eello_t4/4.0d0*lipscale
4769          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4770           ssgradlipj*eello_t4/4.0d0*lipscale
4771          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4772           ssgradlipi*eello_t4/4.0d0*lipscale
4773          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4774           ssgradlipj*eello_t4/4.0d0*lipscale
4775
4776       return
4777       end subroutine eturn4
4778 !-----------------------------------------------------------------------------
4779       subroutine unormderiv(u,ugrad,unorm,ungrad)
4780 ! This subroutine computes the derivatives of a normalized vector u, given
4781 ! the derivatives computed without normalization conditions, ugrad. Returns
4782 ! ungrad.
4783 !      implicit none
4784       real(kind=8),dimension(3) :: u,vec
4785       real(kind=8),dimension(3,3) ::ugrad,ungrad
4786       real(kind=8) :: unorm      !,scalar
4787       integer :: i,j
4788 !      write (2,*) 'ugrad',ugrad
4789 !      write (2,*) 'u',u
4790       do i=1,3
4791         vec(i)=scalar(ugrad(1,i),u(1))
4792       enddo
4793 !      write (2,*) 'vec',vec
4794       do i=1,3
4795         do j=1,3
4796           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4797         enddo
4798       enddo
4799 !      write (2,*) 'ungrad',ungrad
4800       return
4801       end subroutine unormderiv
4802 !-----------------------------------------------------------------------------
4803       subroutine escp_soft_sphere(evdw2,evdw2_14)
4804 !
4805 ! This subroutine calculates the excluded-volume interaction energy between
4806 ! peptide-group centers and side chains and its gradient in virtual-bond and
4807 ! side-chain vectors.
4808 !
4809 !      implicit real*8 (a-h,o-z)
4810 !      include 'DIMENSIONS'
4811 !      include 'COMMON.GEO'
4812 !      include 'COMMON.VAR'
4813 !      include 'COMMON.LOCAL'
4814 !      include 'COMMON.CHAIN'
4815 !      include 'COMMON.DERIV'
4816 !      include 'COMMON.INTERACT'
4817 !      include 'COMMON.FFIELD'
4818 !      include 'COMMON.IOUNITS'
4819 !      include 'COMMON.CONTROL'
4820       real(kind=8),dimension(3) :: ggg
4821 !el local variables
4822       integer :: i,iint,j,k,iteli,itypj
4823       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4824                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4825
4826       evdw2=0.0D0
4827       evdw2_14=0.0d0
4828       r0_scp=4.5d0
4829 !d    print '(a)','Enter ESCP'
4830 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4831       do i=iatscp_s,iatscp_e
4832         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4833         iteli=itel(i)
4834         xi=0.5D0*(c(1,i)+c(1,i+1))
4835         yi=0.5D0*(c(2,i)+c(2,i+1))
4836         zi=0.5D0*(c(3,i)+c(3,i+1))
4837
4838         do iint=1,nscp_gr(i)
4839
4840         do j=iscpstart(i,iint),iscpend(i,iint)
4841           if (itype(j,1).eq.ntyp1) cycle
4842           itypj=iabs(itype(j,1))
4843 ! Uncomment following three lines for SC-p interactions
4844 !         xj=c(1,nres+j)-xi
4845 !         yj=c(2,nres+j)-yi
4846 !         zj=c(3,nres+j)-zi
4847 ! Uncomment following three lines for Ca-p interactions
4848           xj=c(1,j)-xi
4849           yj=c(2,j)-yi
4850           zj=c(3,j)-zi
4851           rij=xj*xj+yj*yj+zj*zj
4852           r0ij=r0_scp
4853           r0ijsq=r0ij*r0ij
4854           if (rij.lt.r0ijsq) then
4855             evdwij=0.25d0*(rij-r0ijsq)**2
4856             fac=rij-r0ijsq
4857           else
4858             evdwij=0.0d0
4859             fac=0.0d0
4860           endif
4861           evdw2=evdw2+evdwij
4862 !
4863 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4864 !
4865           ggg(1)=xj*fac
4866           ggg(2)=yj*fac
4867           ggg(3)=zj*fac
4868 !grad          if (j.lt.i) then
4869 !d          write (iout,*) 'j<i'
4870 ! Uncomment following three lines for SC-p interactions
4871 !           do k=1,3
4872 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4873 !           enddo
4874 !grad          else
4875 !d          write (iout,*) 'j>i'
4876 !grad            do k=1,3
4877 !grad              ggg(k)=-ggg(k)
4878 ! Uncomment following line for SC-p interactions
4879 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4880 !grad            enddo
4881 !grad          endif
4882 !grad          do k=1,3
4883 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4884 !grad          enddo
4885 !grad          kstart=min0(i+1,j)
4886 !grad          kend=max0(i-1,j-1)
4887 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4888 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4889 !grad          do k=kstart,kend
4890 !grad            do l=1,3
4891 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4892 !grad            enddo
4893 !grad          enddo
4894           do k=1,3
4895             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4896             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4897           enddo
4898         enddo
4899
4900         enddo ! iint
4901       enddo ! i
4902       return
4903       end subroutine escp_soft_sphere
4904 !-----------------------------------------------------------------------------
4905       subroutine escp(evdw2,evdw2_14)
4906 !
4907 ! This subroutine calculates the excluded-volume interaction energy between
4908 ! peptide-group centers and side chains and its gradient in virtual-bond and
4909 ! side-chain vectors.
4910 !
4911 !      implicit real*8 (a-h,o-z)
4912 !      include 'DIMENSIONS'
4913 !      include 'COMMON.GEO'
4914 !      include 'COMMON.VAR'
4915 !      include 'COMMON.LOCAL'
4916 !      include 'COMMON.CHAIN'
4917 !      include 'COMMON.DERIV'
4918 !      include 'COMMON.INTERACT'
4919 !      include 'COMMON.FFIELD'
4920 !      include 'COMMON.IOUNITS'
4921 !      include 'COMMON.CONTROL'
4922       real(kind=8),dimension(3) :: ggg
4923 !el local variables
4924       integer :: i,iint,j,k,iteli,itypj,subchap
4925       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4926                    e1,e2,evdwij,rij
4927       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4928                     dist_temp, dist_init
4929       integer xshift,yshift,zshift
4930
4931       evdw2=0.0D0
4932       evdw2_14=0.0d0
4933 !d    print '(a)','Enter ESCP'
4934 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4935       do i=iatscp_s,iatscp_e
4936         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4937         iteli=itel(i)
4938         xi=0.5D0*(c(1,i)+c(1,i+1))
4939         yi=0.5D0*(c(2,i)+c(2,i+1))
4940         zi=0.5D0*(c(3,i)+c(3,i+1))
4941           xi=mod(xi,boxxsize)
4942           if (xi.lt.0) xi=xi+boxxsize
4943           yi=mod(yi,boxysize)
4944           if (yi.lt.0) yi=yi+boxysize
4945           zi=mod(zi,boxzsize)
4946           if (zi.lt.0) zi=zi+boxzsize
4947
4948         do iint=1,nscp_gr(i)
4949
4950         do j=iscpstart(i,iint),iscpend(i,iint)
4951           itypj=iabs(itype(j,1))
4952           if (itypj.eq.ntyp1) cycle
4953 ! Uncomment following three lines for SC-p interactions
4954 !         xj=c(1,nres+j)-xi
4955 !         yj=c(2,nres+j)-yi
4956 !         zj=c(3,nres+j)-zi
4957 ! Uncomment following three lines for Ca-p interactions
4958 !          xj=c(1,j)-xi
4959 !          yj=c(2,j)-yi
4960 !          zj=c(3,j)-zi
4961           xj=c(1,j)
4962           yj=c(2,j)
4963           zj=c(3,j)
4964           xj=mod(xj,boxxsize)
4965           if (xj.lt.0) xj=xj+boxxsize
4966           yj=mod(yj,boxysize)
4967           if (yj.lt.0) yj=yj+boxysize
4968           zj=mod(zj,boxzsize)
4969           if (zj.lt.0) zj=zj+boxzsize
4970       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4971       xj_safe=xj
4972       yj_safe=yj
4973       zj_safe=zj
4974       subchap=0
4975       do xshift=-1,1
4976       do yshift=-1,1
4977       do zshift=-1,1
4978           xj=xj_safe+xshift*boxxsize
4979           yj=yj_safe+yshift*boxysize
4980           zj=zj_safe+zshift*boxzsize
4981           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4982           if(dist_temp.lt.dist_init) then
4983             dist_init=dist_temp
4984             xj_temp=xj
4985             yj_temp=yj
4986             zj_temp=zj
4987             subchap=1
4988           endif
4989        enddo
4990        enddo
4991        enddo
4992        if (subchap.eq.1) then
4993           xj=xj_temp-xi
4994           yj=yj_temp-yi
4995           zj=zj_temp-zi
4996        else
4997           xj=xj_safe-xi
4998           yj=yj_safe-yi
4999           zj=zj_safe-zi
5000        endif
5001
5002           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5003           rij=dsqrt(1.0d0/rrij)
5004             sss_ele_cut=sscale_ele(rij)
5005             sss_ele_grad=sscagrad_ele(rij)
5006 !            print *,sss_ele_cut,sss_ele_grad,&
5007 !            (rij),r_cut_ele,rlamb_ele
5008             if (sss_ele_cut.le.0.0) cycle
5009           fac=rrij**expon2
5010           e1=fac*fac*aad(itypj,iteli)
5011           e2=fac*bad(itypj,iteli)
5012           if (iabs(j-i) .le. 2) then
5013             e1=scal14*e1
5014             e2=scal14*e2
5015             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5016           endif
5017           evdwij=e1+e2
5018           evdw2=evdw2+evdwij*sss_ele_cut
5019 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5020 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5021           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5022              'evdw2',i,j,evdwij
5023 !
5024 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5025 !
5026           fac=-(evdwij+e1)*rrij*sss_ele_cut
5027           fac=fac+evdwij*sss_ele_grad/rij/expon
5028           ggg(1)=xj*fac
5029           ggg(2)=yj*fac
5030           ggg(3)=zj*fac
5031 !grad          if (j.lt.i) then
5032 !d          write (iout,*) 'j<i'
5033 ! Uncomment following three lines for SC-p interactions
5034 !           do k=1,3
5035 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5036 !           enddo
5037 !grad          else
5038 !d          write (iout,*) 'j>i'
5039 !grad            do k=1,3
5040 !grad              ggg(k)=-ggg(k)
5041 ! Uncomment following line for SC-p interactions
5042 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5043 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5044 !grad            enddo
5045 !grad          endif
5046 !grad          do k=1,3
5047 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5048 !grad          enddo
5049 !grad          kstart=min0(i+1,j)
5050 !grad          kend=max0(i-1,j-1)
5051 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5052 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5053 !grad          do k=kstart,kend
5054 !grad            do l=1,3
5055 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5056 !grad            enddo
5057 !grad          enddo
5058           do k=1,3
5059             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5060             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5061           enddo
5062         enddo
5063
5064         enddo ! iint
5065       enddo ! i
5066       do i=1,nct
5067         do j=1,3
5068           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5069           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5070           gradx_scp(j,i)=expon*gradx_scp(j,i)
5071         enddo
5072       enddo
5073 !******************************************************************************
5074 !
5075 !                              N O T E !!!
5076 !
5077 ! To save time the factor EXPON has been extracted from ALL components
5078 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5079 ! use!
5080 !
5081 !******************************************************************************
5082       return
5083       end subroutine escp
5084 !-----------------------------------------------------------------------------
5085       subroutine edis(ehpb)
5086 !
5087 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5088 !
5089 !      implicit real*8 (a-h,o-z)
5090 !      include 'DIMENSIONS'
5091 !      include 'COMMON.SBRIDGE'
5092 !      include 'COMMON.CHAIN'
5093 !      include 'COMMON.DERIV'
5094 !      include 'COMMON.VAR'
5095 !      include 'COMMON.INTERACT'
5096 !      include 'COMMON.IOUNITS'
5097       real(kind=8),dimension(3) :: ggg
5098 !el local variables
5099       integer :: i,j,ii,jj,iii,jjj,k
5100       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5101
5102       ehpb=0.0D0
5103 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5104 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5105       if (link_end.eq.0) return
5106       do i=link_start,link_end
5107 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5108 ! CA-CA distance used in regularization of structure.
5109         ii=ihpb(i)
5110         jj=jhpb(i)
5111 ! iii and jjj point to the residues for which the distance is assigned.
5112         if (ii.gt.nres) then
5113           iii=ii-nres
5114           jjj=jj-nres
5115         else
5116           iii=ii
5117           jjj=jj
5118         endif
5119 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5120 !     &    dhpb(i),dhpb1(i),forcon(i)
5121 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5122 !    distance and angle dependent SS bond potential.
5123 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5124 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5125         if (.not.dyn_ss .and. i.le.nss) then
5126 ! 15/02/13 CC dynamic SSbond - additional check
5127          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5128         iabs(itype(jjj,1)).eq.1) then
5129           call ssbond_ene(iii,jjj,eij)
5130           ehpb=ehpb+2*eij
5131 !d          write (iout,*) "eij",eij
5132          endif
5133         else if (ii.gt.nres .and. jj.gt.nres) then
5134 !c Restraints from contact prediction
5135           dd=dist(ii,jj)
5136           if (constr_dist.eq.11) then
5137             ehpb=ehpb+fordepth(i)**4.0d0 &
5138                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5139             fac=fordepth(i)**4.0d0 &
5140                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5141           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5142             ehpb,fordepth(i),dd
5143            else
5144           if (dhpb1(i).gt.0.0d0) then
5145             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5146             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5147 !c            write (iout,*) "beta nmr",
5148 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5149           else
5150             dd=dist(ii,jj)
5151             rdis=dd-dhpb(i)
5152 !C Get the force constant corresponding to this distance.
5153             waga=forcon(i)
5154 !C Calculate the contribution to energy.
5155             ehpb=ehpb+waga*rdis*rdis
5156 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5157 !C
5158 !C Evaluate gradient.
5159 !C
5160             fac=waga*rdis/dd
5161           endif
5162           endif
5163           do j=1,3
5164             ggg(j)=fac*(c(j,jj)-c(j,ii))
5165           enddo
5166           do j=1,3
5167             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5168             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5169           enddo
5170           do k=1,3
5171             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5172             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5173           enddo
5174         else
5175           dd=dist(ii,jj)
5176           if (constr_dist.eq.11) then
5177             ehpb=ehpb+fordepth(i)**4.0d0 &
5178                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5179             fac=fordepth(i)**4.0d0 &
5180                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5181           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5182          ehpb,fordepth(i),dd
5183            else
5184           if (dhpb1(i).gt.0.0d0) then
5185             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5186             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5187 !c            write (iout,*) "alph nmr",
5188 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5189           else
5190             rdis=dd-dhpb(i)
5191 !C Get the force constant corresponding to this distance.
5192             waga=forcon(i)
5193 !C Calculate the contribution to energy.
5194             ehpb=ehpb+waga*rdis*rdis
5195 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5196 !C
5197 !C Evaluate gradient.
5198 !C
5199             fac=waga*rdis/dd
5200           endif
5201           endif
5202
5203             do j=1,3
5204               ggg(j)=fac*(c(j,jj)-c(j,ii))
5205             enddo
5206 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5207 !C If this is a SC-SC distance, we need to calculate the contributions to the
5208 !C Cartesian gradient in the SC vectors (ghpbx).
5209           if (iii.lt.ii) then
5210           do j=1,3
5211             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5212             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5213           enddo
5214           endif
5215 !cgrad        do j=iii,jjj-1
5216 !cgrad          do k=1,3
5217 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5218 !cgrad          enddo
5219 !cgrad        enddo
5220           do k=1,3
5221             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5222             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5223           enddo
5224         endif
5225       enddo
5226       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5227
5228       return
5229       end subroutine edis
5230 !-----------------------------------------------------------------------------
5231       subroutine ssbond_ene(i,j,eij)
5232 !
5233 ! Calculate the distance and angle dependent SS-bond potential energy
5234 ! using a free-energy function derived based on RHF/6-31G** ab initio
5235 ! calculations of diethyl disulfide.
5236 !
5237 ! A. Liwo and U. Kozlowska, 11/24/03
5238 !
5239 !      implicit real*8 (a-h,o-z)
5240 !      include 'DIMENSIONS'
5241 !      include 'COMMON.SBRIDGE'
5242 !      include 'COMMON.CHAIN'
5243 !      include 'COMMON.DERIV'
5244 !      include 'COMMON.LOCAL'
5245 !      include 'COMMON.INTERACT'
5246 !      include 'COMMON.VAR'
5247 !      include 'COMMON.IOUNITS'
5248       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5249 !el local variables
5250       integer :: i,j,itypi,itypj,k
5251       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5252                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5253                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5254                    cosphi,ggk
5255
5256       itypi=iabs(itype(i,1))
5257       xi=c(1,nres+i)
5258       yi=c(2,nres+i)
5259       zi=c(3,nres+i)
5260       dxi=dc_norm(1,nres+i)
5261       dyi=dc_norm(2,nres+i)
5262       dzi=dc_norm(3,nres+i)
5263 !      dsci_inv=dsc_inv(itypi)
5264       dsci_inv=vbld_inv(nres+i)
5265       itypj=iabs(itype(j,1))
5266 !      dscj_inv=dsc_inv(itypj)
5267       dscj_inv=vbld_inv(nres+j)
5268       xj=c(1,nres+j)-xi
5269       yj=c(2,nres+j)-yi
5270       zj=c(3,nres+j)-zi
5271       dxj=dc_norm(1,nres+j)
5272       dyj=dc_norm(2,nres+j)
5273       dzj=dc_norm(3,nres+j)
5274       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5275       rij=dsqrt(rrij)
5276       erij(1)=xj*rij
5277       erij(2)=yj*rij
5278       erij(3)=zj*rij
5279       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5280       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5281       om12=dxi*dxj+dyi*dyj+dzi*dzj
5282       do k=1,3
5283         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5284         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5285       enddo
5286       rij=1.0d0/rij
5287       deltad=rij-d0cm
5288       deltat1=1.0d0-om1
5289       deltat2=1.0d0+om2
5290       deltat12=om2-om1+2.0d0
5291       cosphi=om12-om1*om2
5292       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5293         +akct*deltad*deltat12 &
5294         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5295 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5296 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5297 !     &  " deltat12",deltat12," eij",eij
5298       ed=2*akcm*deltad+akct*deltat12
5299       pom1=akct*deltad
5300       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5301       eom1=-2*akth*deltat1-pom1-om2*pom2
5302       eom2= 2*akth*deltat2+pom1-om1*pom2
5303       eom12=pom2
5304       do k=1,3
5305         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5306         ghpbx(k,i)=ghpbx(k,i)-ggk &
5307                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5308                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5309         ghpbx(k,j)=ghpbx(k,j)+ggk &
5310                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5311                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5312         ghpbc(k,i)=ghpbc(k,i)-ggk
5313         ghpbc(k,j)=ghpbc(k,j)+ggk
5314       enddo
5315 !
5316 ! Calculate the components of the gradient in DC and X
5317 !
5318 !grad      do k=i,j-1
5319 !grad        do l=1,3
5320 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5321 !grad        enddo
5322 !grad      enddo
5323       return
5324       end subroutine ssbond_ene
5325 !-----------------------------------------------------------------------------
5326       subroutine ebond(estr)
5327 !
5328 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5329 !
5330 !      implicit real*8 (a-h,o-z)
5331 !      include 'DIMENSIONS'
5332 !      include 'COMMON.LOCAL'
5333 !      include 'COMMON.GEO'
5334 !      include 'COMMON.INTERACT'
5335 !      include 'COMMON.DERIV'
5336 !      include 'COMMON.VAR'
5337 !      include 'COMMON.CHAIN'
5338 !      include 'COMMON.IOUNITS'
5339 !      include 'COMMON.NAMES'
5340 !      include 'COMMON.FFIELD'
5341 !      include 'COMMON.CONTROL'
5342 !      include 'COMMON.SETUP'
5343       real(kind=8),dimension(3) :: u,ud
5344 !el local variables
5345       integer :: i,j,iti,nbi,k
5346       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5347                    uprod1,uprod2
5348
5349       estr=0.0d0
5350       estr1=0.0d0
5351 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5352 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5353
5354       do i=ibondp_start,ibondp_end
5355         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5356         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5357 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5358 !C          do j=1,3
5359 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5360 !C            *dc(j,i-1)/vbld(i)
5361 !C          enddo
5362 !C          if (energy_dec) write(iout,*) &
5363 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5364         diff = vbld(i)-vbldpDUM
5365         else
5366         diff = vbld(i)-vbldp0
5367         endif
5368         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5369            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5370         estr=estr+diff*diff
5371         do j=1,3
5372           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5373         enddo
5374 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5375 !        endif
5376       enddo
5377       estr=0.5d0*AKP*estr+estr1
5378 !      print *,"estr_bb",estr,AKP
5379 !
5380 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5381 !
5382       do i=ibond_start,ibond_end
5383         iti=iabs(itype(i,1))
5384         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5385         if (iti.ne.10 .and. iti.ne.ntyp1) then
5386           nbi=nbondterm(iti)
5387           if (nbi.eq.1) then
5388             diff=vbld(i+nres)-vbldsc0(1,iti)
5389             if (energy_dec) write (iout,*) &
5390             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5391             AKSC(1,iti),AKSC(1,iti)*diff*diff
5392             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5393 !            print *,"estr_sc",estr
5394             do j=1,3
5395               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5396             enddo
5397           else
5398             do j=1,nbi
5399               diff=vbld(i+nres)-vbldsc0(j,iti)
5400               ud(j)=aksc(j,iti)*diff
5401               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5402             enddo
5403             uprod=u(1)
5404             do j=2,nbi
5405               uprod=uprod*u(j)
5406             enddo
5407             usum=0.0d0
5408             usumsqder=0.0d0
5409             do j=1,nbi
5410               uprod1=1.0d0
5411               uprod2=1.0d0
5412               do k=1,nbi
5413                 if (k.ne.j) then
5414                   uprod1=uprod1*u(k)
5415                   uprod2=uprod2*u(k)*u(k)
5416                 endif
5417               enddo
5418               usum=usum+uprod1
5419               usumsqder=usumsqder+ud(j)*uprod2
5420             enddo
5421             estr=estr+uprod/usum
5422 !            print *,"estr_sc",estr,i
5423
5424              if (energy_dec) write (iout,*) &
5425             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5426             AKSC(1,iti),uprod/usum
5427             do j=1,3
5428              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5429             enddo
5430           endif
5431         endif
5432       enddo
5433       return
5434       end subroutine ebond
5435 #ifdef CRYST_THETA
5436 !-----------------------------------------------------------------------------
5437       subroutine ebend(etheta)
5438 !
5439 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5440 ! angles gamma and its derivatives in consecutive thetas and gammas.
5441 !
5442       use comm_calcthet
5443 !      implicit real*8 (a-h,o-z)
5444 !      include 'DIMENSIONS'
5445 !      include 'COMMON.LOCAL'
5446 !      include 'COMMON.GEO'
5447 !      include 'COMMON.INTERACT'
5448 !      include 'COMMON.DERIV'
5449 !      include 'COMMON.VAR'
5450 !      include 'COMMON.CHAIN'
5451 !      include 'COMMON.IOUNITS'
5452 !      include 'COMMON.NAMES'
5453 !      include 'COMMON.FFIELD'
5454 !      include 'COMMON.CONTROL'
5455 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5456 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5457 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5458 !el      integer :: it
5459 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5460 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5461 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5462 !el local variables
5463       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5464        ichir21,ichir22
5465       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5466        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5467        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5468       real(kind=8),dimension(2) :: y,z
5469
5470       delta=0.02d0*pi
5471 !      time11=dexp(-2*time)
5472 !      time12=1.0d0
5473       etheta=0.0D0
5474 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5475       do i=ithet_start,ithet_end
5476         if (itype(i-1,1).eq.ntyp1) cycle
5477 ! Zero the energy function and its derivative at 0 or pi.
5478         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5479         it=itype(i-1,1)
5480         ichir1=isign(1,itype(i-2,1))
5481         ichir2=isign(1,itype(i,1))
5482          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5483          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5484          if (itype(i-1,1).eq.10) then
5485           itype1=isign(10,itype(i-2,1))
5486           ichir11=isign(1,itype(i-2,1))
5487           ichir12=isign(1,itype(i-2,1))
5488           itype2=isign(10,itype(i,1))
5489           ichir21=isign(1,itype(i,1))
5490           ichir22=isign(1,itype(i,1))
5491          endif
5492
5493         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5494 #ifdef OSF
5495           phii=phi(i)
5496           if (phii.ne.phii) phii=150.0
5497 #else
5498           phii=phi(i)
5499 #endif
5500           y(1)=dcos(phii)
5501           y(2)=dsin(phii)
5502         else
5503           y(1)=0.0D0
5504           y(2)=0.0D0
5505         endif
5506         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5507 #ifdef OSF
5508           phii1=phi(i+1)
5509           if (phii1.ne.phii1) phii1=150.0
5510           phii1=pinorm(phii1)
5511           z(1)=cos(phii1)
5512 #else
5513           phii1=phi(i+1)
5514           z(1)=dcos(phii1)
5515 #endif
5516           z(2)=dsin(phii1)
5517         else
5518           z(1)=0.0D0
5519           z(2)=0.0D0
5520         endif
5521 ! Calculate the "mean" value of theta from the part of the distribution
5522 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5523 ! In following comments this theta will be referred to as t_c.
5524         thet_pred_mean=0.0d0
5525         do k=1,2
5526             athetk=athet(k,it,ichir1,ichir2)
5527             bthetk=bthet(k,it,ichir1,ichir2)
5528           if (it.eq.10) then
5529              athetk=athet(k,itype1,ichir11,ichir12)
5530              bthetk=bthet(k,itype2,ichir21,ichir22)
5531           endif
5532          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5533         enddo
5534         dthett=thet_pred_mean*ssd
5535         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5536 ! Derivatives of the "mean" values in gamma1 and gamma2.
5537         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5538                +athet(2,it,ichir1,ichir2)*y(1))*ss
5539         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5540                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5541          if (it.eq.10) then
5542         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5543              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5544         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5545                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5546          endif
5547         if (theta(i).gt.pi-delta) then
5548           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5549                E_tc0)
5550           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5551           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5552           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5553               E_theta)
5554           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5555               E_tc)
5556         else if (theta(i).lt.delta) then
5557           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5558           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5559           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5560               E_theta)
5561           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5562           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5563               E_tc)
5564         else
5565           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5566               E_theta,E_tc)
5567         endif
5568         etheta=etheta+ethetai
5569         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5570             'ebend',i,ethetai
5571         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5572         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5573         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5574       enddo
5575 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5576
5577 ! Ufff.... We've done all this!!!
5578       return
5579       end subroutine ebend
5580 !-----------------------------------------------------------------------------
5581       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5582
5583       use comm_calcthet
5584 !      implicit real*8 (a-h,o-z)
5585 !      include 'DIMENSIONS'
5586 !      include 'COMMON.LOCAL'
5587 !      include 'COMMON.IOUNITS'
5588 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5589 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5590 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5591       integer :: i,j,k
5592       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5593 !el      integer :: it
5594 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5595 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5596 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5597 !el local variables
5598       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5599        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5600
5601 ! Calculate the contributions to both Gaussian lobes.
5602 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5603 ! The "polynomial part" of the "standard deviation" of this part of
5604 ! the distribution.
5605         sig=polthet(3,it)
5606         do j=2,0,-1
5607           sig=sig*thet_pred_mean+polthet(j,it)
5608         enddo
5609 ! Derivative of the "interior part" of the "standard deviation of the"
5610 ! gamma-dependent Gaussian lobe in t_c.
5611         sigtc=3*polthet(3,it)
5612         do j=2,1,-1
5613           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5614         enddo
5615         sigtc=sig*sigtc
5616 ! Set the parameters of both Gaussian lobes of the distribution.
5617 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5618         fac=sig*sig+sigc0(it)
5619         sigcsq=fac+fac
5620         sigc=1.0D0/sigcsq
5621 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5622         sigsqtc=-4.0D0*sigcsq*sigtc
5623 !       print *,i,sig,sigtc,sigsqtc
5624 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5625         sigtc=-sigtc/(fac*fac)
5626 ! Following variable is sigma(t_c)**(-2)
5627         sigcsq=sigcsq*sigcsq
5628         sig0i=sig0(it)
5629         sig0inv=1.0D0/sig0i**2
5630         delthec=thetai-thet_pred_mean
5631         delthe0=thetai-theta0i
5632         term1=-0.5D0*sigcsq*delthec*delthec
5633         term2=-0.5D0*sig0inv*delthe0*delthe0
5634 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5635 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5636 ! to the energy (this being the log of the distribution) at the end of energy
5637 ! term evaluation for this virtual-bond angle.
5638         if (term1.gt.term2) then
5639           termm=term1
5640           term2=dexp(term2-termm)
5641           term1=1.0d0
5642         else
5643           termm=term2
5644           term1=dexp(term1-termm)
5645           term2=1.0d0
5646         endif
5647 ! The ratio between the gamma-independent and gamma-dependent lobes of
5648 ! the distribution is a Gaussian function of thet_pred_mean too.
5649         diffak=gthet(2,it)-thet_pred_mean
5650         ratak=diffak/gthet(3,it)**2
5651         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5652 ! Let's differentiate it in thet_pred_mean NOW.
5653         aktc=ak*ratak
5654 ! Now put together the distribution terms to make complete distribution.
5655         termexp=term1+ak*term2
5656         termpre=sigc+ak*sig0i
5657 ! Contribution of the bending energy from this theta is just the -log of
5658 ! the sum of the contributions from the two lobes and the pre-exponential
5659 ! factor. Simple enough, isn't it?
5660         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5661 ! NOW the derivatives!!!
5662 ! 6/6/97 Take into account the deformation.
5663         E_theta=(delthec*sigcsq*term1 &
5664              +ak*delthe0*sig0inv*term2)/termexp
5665         E_tc=((sigtc+aktc*sig0i)/termpre &
5666             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5667              aktc*term2)/termexp)
5668       return
5669       end subroutine theteng
5670 #else
5671 !-----------------------------------------------------------------------------
5672       subroutine ebend(etheta,ethetacnstr)
5673 !
5674 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5675 ! angles gamma and its derivatives in consecutive thetas and gammas.
5676 ! ab initio-derived potentials from
5677 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5678 !
5679 !      implicit real*8 (a-h,o-z)
5680 !      include 'DIMENSIONS'
5681 !      include 'COMMON.LOCAL'
5682 !      include 'COMMON.GEO'
5683 !      include 'COMMON.INTERACT'
5684 !      include 'COMMON.DERIV'
5685 !      include 'COMMON.VAR'
5686 !      include 'COMMON.CHAIN'
5687 !      include 'COMMON.IOUNITS'
5688 !      include 'COMMON.NAMES'
5689 !      include 'COMMON.FFIELD'
5690 !      include 'COMMON.CONTROL'
5691       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5692       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5693       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5694       logical :: lprn=.false., lprn1=.false.
5695 !el local variables
5696       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5697       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5698       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5699 ! local variables for constrains
5700       real(kind=8) :: difi,thetiii
5701        integer itheta
5702
5703       etheta=0.0D0
5704       do i=ithet_start,ithet_end
5705         if (itype(i-1,1).eq.ntyp1) cycle
5706         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5707         if (iabs(itype(i+1,1)).eq.20) iblock=2
5708         if (iabs(itype(i+1,1)).ne.20) iblock=1
5709         dethetai=0.0d0
5710         dephii=0.0d0
5711         dephii1=0.0d0
5712         theti2=0.5d0*theta(i)
5713         ityp2=ithetyp((itype(i-1,1)))
5714         do k=1,nntheterm
5715           coskt(k)=dcos(k*theti2)
5716           sinkt(k)=dsin(k*theti2)
5717         enddo
5718         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5719 #ifdef OSF
5720           phii=phi(i)
5721           if (phii.ne.phii) phii=150.0
5722 #else
5723           phii=phi(i)
5724 #endif
5725           ityp1=ithetyp((itype(i-2,1)))
5726 ! propagation of chirality for glycine type
5727           do k=1,nsingle
5728             cosph1(k)=dcos(k*phii)
5729             sinph1(k)=dsin(k*phii)
5730           enddo
5731         else
5732           phii=0.0d0
5733           ityp1=ithetyp(itype(i-2,1))
5734           do k=1,nsingle
5735             cosph1(k)=0.0d0
5736             sinph1(k)=0.0d0
5737           enddo
5738         endif
5739         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5740 #ifdef OSF
5741           phii1=phi(i+1)
5742           if (phii1.ne.phii1) phii1=150.0
5743           phii1=pinorm(phii1)
5744 #else
5745           phii1=phi(i+1)
5746 #endif
5747           ityp3=ithetyp((itype(i,1)))
5748           do k=1,nsingle
5749             cosph2(k)=dcos(k*phii1)
5750             sinph2(k)=dsin(k*phii1)
5751           enddo
5752         else
5753           phii1=0.0d0
5754           ityp3=ithetyp(itype(i,1))
5755           do k=1,nsingle
5756             cosph2(k)=0.0d0
5757             sinph2(k)=0.0d0
5758           enddo
5759         endif
5760         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5761         do k=1,ndouble
5762           do l=1,k-1
5763             ccl=cosph1(l)*cosph2(k-l)
5764             ssl=sinph1(l)*sinph2(k-l)
5765             scl=sinph1(l)*cosph2(k-l)
5766             csl=cosph1(l)*sinph2(k-l)
5767             cosph1ph2(l,k)=ccl-ssl
5768             cosph1ph2(k,l)=ccl+ssl
5769             sinph1ph2(l,k)=scl+csl
5770             sinph1ph2(k,l)=scl-csl
5771           enddo
5772         enddo
5773         if (lprn) then
5774         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5775           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5776         write (iout,*) "coskt and sinkt"
5777         do k=1,nntheterm
5778           write (iout,*) k,coskt(k),sinkt(k)
5779         enddo
5780         endif
5781         do k=1,ntheterm
5782           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5783           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5784             *coskt(k)
5785           if (lprn) &
5786           write (iout,*) "k",k,&
5787            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5788            " ethetai",ethetai
5789         enddo
5790         if (lprn) then
5791         write (iout,*) "cosph and sinph"
5792         do k=1,nsingle
5793           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5794         enddo
5795         write (iout,*) "cosph1ph2 and sinph2ph2"
5796         do k=2,ndouble
5797           do l=1,k-1
5798             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5799                sinph1ph2(l,k),sinph1ph2(k,l)
5800           enddo
5801         enddo
5802         write(iout,*) "ethetai",ethetai
5803         endif
5804         do m=1,ntheterm2
5805           do k=1,nsingle
5806             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5807                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5808                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5809                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5810             ethetai=ethetai+sinkt(m)*aux
5811             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5812             dephii=dephii+k*sinkt(m)* &
5813                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5814                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5815             dephii1=dephii1+k*sinkt(m)* &
5816                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5817                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5818             if (lprn) &
5819             write (iout,*) "m",m," k",k," bbthet", &
5820                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5821                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5822                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5823                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5824           enddo
5825         enddo
5826         if (lprn) &
5827         write(iout,*) "ethetai",ethetai
5828         do m=1,ntheterm3
5829           do k=2,ndouble
5830             do l=1,k-1
5831               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5832                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5833                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5834                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5835               ethetai=ethetai+sinkt(m)*aux
5836               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5837               dephii=dephii+l*sinkt(m)* &
5838                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5839                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5840                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5841                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5842               dephii1=dephii1+(k-l)*sinkt(m)* &
5843                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5844                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5845                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5846                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5847               if (lprn) then
5848               write (iout,*) "m",m," k",k," l",l," ffthet",&
5849                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5850                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5851                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5852                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5853                   " ethetai",ethetai
5854               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5855                   cosph1ph2(k,l)*sinkt(m),&
5856                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5857               endif
5858             enddo
5859           enddo
5860         enddo
5861 10      continue
5862 !        lprn1=.true.
5863         if (lprn1) &
5864           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5865          i,theta(i)*rad2deg,phii*rad2deg,&
5866          phii1*rad2deg,ethetai
5867 !        lprn1=.false.
5868         etheta=etheta+ethetai
5869         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5870                                     'ebend',i,ethetai
5871         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5872         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5873         gloc(nphi+i-2,icg)=wang*dethetai
5874       enddo
5875 !-----------thete constrains
5876 !      if (tor_mode.ne.2) then
5877       ethetacnstr=0.0d0
5878 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5879       do i=ithetaconstr_start,ithetaconstr_end
5880         itheta=itheta_constr(i)
5881         thetiii=theta(itheta)
5882         difi=pinorm(thetiii-theta_constr0(i))
5883         if (difi.gt.theta_drange(i)) then
5884           difi=difi-theta_drange(i)
5885           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5886           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5887          +for_thet_constr(i)*difi**3
5888         else if (difi.lt.-drange(i)) then
5889           difi=difi+drange(i)
5890           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5891           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5892          +for_thet_constr(i)*difi**3
5893         else
5894           difi=0.0
5895         endif
5896        if (energy_dec) then
5897         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5898          i,itheta,rad2deg*thetiii, &
5899          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5900          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5901          gloc(itheta+nphi-2,icg)
5902         endif
5903       enddo
5904 !      endif
5905
5906       return
5907       end subroutine ebend
5908 #endif
5909 #ifdef CRYST_SC
5910 !-----------------------------------------------------------------------------
5911       subroutine esc(escloc)
5912 ! Calculate the local energy of a side chain and its derivatives in the
5913 ! corresponding virtual-bond valence angles THETA and the spherical angles
5914 ! ALPHA and OMEGA.
5915 !
5916       use comm_sccalc
5917 !      implicit real*8 (a-h,o-z)
5918 !      include 'DIMENSIONS'
5919 !      include 'COMMON.GEO'
5920 !      include 'COMMON.LOCAL'
5921 !      include 'COMMON.VAR'
5922 !      include 'COMMON.INTERACT'
5923 !      include 'COMMON.DERIV'
5924 !      include 'COMMON.CHAIN'
5925 !      include 'COMMON.IOUNITS'
5926 !      include 'COMMON.NAMES'
5927 !      include 'COMMON.FFIELD'
5928 !      include 'COMMON.CONTROL'
5929       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5930          ddersc0,ddummy,xtemp,temp
5931 !el      real(kind=8) :: time11,time12,time112,theti
5932       real(kind=8) :: escloc,delta
5933 !el      integer :: it,nlobit
5934 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5935 !el local variables
5936       integer :: i,k
5937       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5938        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5939       delta=0.02d0*pi
5940       escloc=0.0D0
5941 !     write (iout,'(a)') 'ESC'
5942       do i=loc_start,loc_end
5943         it=itype(i,1)
5944         if (it.eq.ntyp1) cycle
5945         if (it.eq.10) goto 1
5946         nlobit=nlob(iabs(it))
5947 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5948 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5949         theti=theta(i+1)-pipol
5950         x(1)=dtan(theti)
5951         x(2)=alph(i)
5952         x(3)=omeg(i)
5953
5954         if (x(2).gt.pi-delta) then
5955           xtemp(1)=x(1)
5956           xtemp(2)=pi-delta
5957           xtemp(3)=x(3)
5958           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5959           xtemp(2)=pi
5960           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5961           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5962               escloci,dersc(2))
5963           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5964               ddersc0(1),dersc(1))
5965           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5966               ddersc0(3),dersc(3))
5967           xtemp(2)=pi-delta
5968           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5969           xtemp(2)=pi
5970           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5971           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5972                   dersc0(2),esclocbi,dersc02)
5973           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5974                   dersc12,dersc01)
5975           call splinthet(x(2),0.5d0*delta,ss,ssd)
5976           dersc0(1)=dersc01
5977           dersc0(2)=dersc02
5978           dersc0(3)=0.0d0
5979           do k=1,3
5980             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5981           enddo
5982           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5983 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5984 !    &             esclocbi,ss,ssd
5985           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5986 !         escloci=esclocbi
5987 !         write (iout,*) escloci
5988         else if (x(2).lt.delta) then
5989           xtemp(1)=x(1)
5990           xtemp(2)=delta
5991           xtemp(3)=x(3)
5992           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5993           xtemp(2)=0.0d0
5994           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5995           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5996               escloci,dersc(2))
5997           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5998               ddersc0(1),dersc(1))
5999           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6000               ddersc0(3),dersc(3))
6001           xtemp(2)=delta
6002           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6003           xtemp(2)=0.0d0
6004           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6005           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6006                   dersc0(2),esclocbi,dersc02)
6007           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6008                   dersc12,dersc01)
6009           dersc0(1)=dersc01
6010           dersc0(2)=dersc02
6011           dersc0(3)=0.0d0
6012           call splinthet(x(2),0.5d0*delta,ss,ssd)
6013           do k=1,3
6014             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6015           enddo
6016           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6017 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6018 !    &             esclocbi,ss,ssd
6019           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6020 !         write (iout,*) escloci
6021         else
6022           call enesc(x,escloci,dersc,ddummy,.false.)
6023         endif
6024
6025         escloc=escloc+escloci
6026         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6027            'escloc',i,escloci
6028 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6029
6030         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6031          wscloc*dersc(1)
6032         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6033         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6034     1   continue
6035       enddo
6036       return
6037       end subroutine esc
6038 !-----------------------------------------------------------------------------
6039       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6040
6041       use comm_sccalc
6042 !      implicit real*8 (a-h,o-z)
6043 !      include 'DIMENSIONS'
6044 !      include 'COMMON.GEO'
6045 !      include 'COMMON.LOCAL'
6046 !      include 'COMMON.IOUNITS'
6047 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6048       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6049       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6050       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6051       real(kind=8) :: escloci
6052       logical :: mixed
6053 !el local variables
6054       integer :: j,iii,l,k !el,it,nlobit
6055       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6056 !el       time11,time12,time112
6057 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6058         escloc_i=0.0D0
6059         do j=1,3
6060           dersc(j)=0.0D0
6061           if (mixed) ddersc(j)=0.0d0
6062         enddo
6063         x3=x(3)
6064
6065 ! Because of periodicity of the dependence of the SC energy in omega we have
6066 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6067 ! To avoid underflows, first compute & store the exponents.
6068
6069         do iii=-1,1
6070
6071           x(3)=x3+iii*dwapi
6072
6073           do j=1,nlobit
6074             do k=1,3
6075               z(k)=x(k)-censc(k,j,it)
6076             enddo
6077             do k=1,3
6078               Axk=0.0D0
6079               do l=1,3
6080                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6081               enddo
6082               Ax(k,j,iii)=Axk
6083             enddo
6084             expfac=0.0D0
6085             do k=1,3
6086               expfac=expfac+Ax(k,j,iii)*z(k)
6087             enddo
6088             contr(j,iii)=expfac
6089           enddo ! j
6090
6091         enddo ! iii
6092
6093         x(3)=x3
6094 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6095 ! subsequent NaNs and INFs in energy calculation.
6096 ! Find the largest exponent
6097         emin=contr(1,-1)
6098         do iii=-1,1
6099           do j=1,nlobit
6100             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6101           enddo
6102         enddo
6103         emin=0.5D0*emin
6104 !d      print *,'it=',it,' emin=',emin
6105
6106 ! Compute the contribution to SC energy and derivatives
6107         do iii=-1,1
6108
6109           do j=1,nlobit
6110 #ifdef OSF
6111             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6112             if(adexp.ne.adexp) adexp=1.0
6113             expfac=dexp(adexp)
6114 #else
6115             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6116 #endif
6117 !d          print *,'j=',j,' expfac=',expfac
6118             escloc_i=escloc_i+expfac
6119             do k=1,3
6120               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6121             enddo
6122             if (mixed) then
6123               do k=1,3,2
6124                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6125                   +gaussc(k,2,j,it))*expfac
6126               enddo
6127             endif
6128           enddo
6129
6130         enddo ! iii
6131
6132         dersc(1)=dersc(1)/cos(theti)**2
6133         ddersc(1)=ddersc(1)/cos(theti)**2
6134         ddersc(3)=ddersc(3)
6135
6136         escloci=-(dlog(escloc_i)-emin)
6137         do j=1,3
6138           dersc(j)=dersc(j)/escloc_i
6139         enddo
6140         if (mixed) then
6141           do j=1,3,2
6142             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6143           enddo
6144         endif
6145       return
6146       end subroutine enesc
6147 !-----------------------------------------------------------------------------
6148       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6149
6150       use comm_sccalc
6151 !      implicit real*8 (a-h,o-z)
6152 !      include 'DIMENSIONS'
6153 !      include 'COMMON.GEO'
6154 !      include 'COMMON.LOCAL'
6155 !      include 'COMMON.IOUNITS'
6156 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6157       real(kind=8),dimension(3) :: x,z,dersc
6158       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6159       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6160       real(kind=8) :: escloci,dersc12,emin
6161       logical :: mixed
6162 !el local varables
6163       integer :: j,k,l !el,it,nlobit
6164       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6165
6166       escloc_i=0.0D0
6167
6168       do j=1,3
6169         dersc(j)=0.0D0
6170       enddo
6171
6172       do j=1,nlobit
6173         do k=1,2
6174           z(k)=x(k)-censc(k,j,it)
6175         enddo
6176         z(3)=dwapi
6177         do k=1,3
6178           Axk=0.0D0
6179           do l=1,3
6180             Axk=Axk+gaussc(l,k,j,it)*z(l)
6181           enddo
6182           Ax(k,j)=Axk
6183         enddo
6184         expfac=0.0D0
6185         do k=1,3
6186           expfac=expfac+Ax(k,j)*z(k)
6187         enddo
6188         contr(j)=expfac
6189       enddo ! j
6190
6191 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6192 ! subsequent NaNs and INFs in energy calculation.
6193 ! Find the largest exponent
6194       emin=contr(1)
6195       do j=1,nlobit
6196         if (emin.gt.contr(j)) emin=contr(j)
6197       enddo
6198       emin=0.5D0*emin
6199
6200 ! Compute the contribution to SC energy and derivatives
6201
6202       dersc12=0.0d0
6203       do j=1,nlobit
6204         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6205         escloc_i=escloc_i+expfac
6206         do k=1,2
6207           dersc(k)=dersc(k)+Ax(k,j)*expfac
6208         enddo
6209         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6210                   +gaussc(1,2,j,it))*expfac
6211         dersc(3)=0.0d0
6212       enddo
6213
6214       dersc(1)=dersc(1)/cos(theti)**2
6215       dersc12=dersc12/cos(theti)**2
6216       escloci=-(dlog(escloc_i)-emin)
6217       do j=1,2
6218         dersc(j)=dersc(j)/escloc_i
6219       enddo
6220       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6221       return
6222       end subroutine enesc_bound
6223 #else
6224 !-----------------------------------------------------------------------------
6225       subroutine esc(escloc)
6226 ! Calculate the local energy of a side chain and its derivatives in the
6227 ! corresponding virtual-bond valence angles THETA and the spherical angles
6228 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6229 ! added by Urszula Kozlowska. 07/11/2007
6230 !
6231       use comm_sccalc
6232 !      implicit real*8 (a-h,o-z)
6233 !      include 'DIMENSIONS'
6234 !      include 'COMMON.GEO'
6235 !      include 'COMMON.LOCAL'
6236 !      include 'COMMON.VAR'
6237 !      include 'COMMON.SCROT'
6238 !      include 'COMMON.INTERACT'
6239 !      include 'COMMON.DERIV'
6240 !      include 'COMMON.CHAIN'
6241 !      include 'COMMON.IOUNITS'
6242 !      include 'COMMON.NAMES'
6243 !      include 'COMMON.FFIELD'
6244 !      include 'COMMON.CONTROL'
6245 !      include 'COMMON.VECTORS'
6246       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6247       real(kind=8),dimension(65) :: x
6248       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6249          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6250       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6251       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6252          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6253 !el local variables
6254       integer :: i,j,k !el,it,nlobit
6255       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6256 !el      real(kind=8) :: time11,time12,time112,theti
6257 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6258       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6259                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6260                    sumene1x,sumene2x,sumene3x,sumene4x,&
6261                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6262                    cosfac2xx,sinfac2yy
6263 #ifdef DEBUG
6264       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6265                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6266                    de_dt_num
6267 #endif
6268 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6269
6270       delta=0.02d0*pi
6271       escloc=0.0D0
6272       do i=loc_start,loc_end
6273         if (itype(i,1).eq.ntyp1) cycle
6274         costtab(i+1) =dcos(theta(i+1))
6275         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6276         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6277         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6278         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6279         cosfac=dsqrt(cosfac2)
6280         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6281         sinfac=dsqrt(sinfac2)
6282         it=iabs(itype(i,1))
6283         if (it.eq.10) goto 1
6284 !
6285 !  Compute the axes of tghe local cartesian coordinates system; store in
6286 !   x_prime, y_prime and z_prime
6287 !
6288         do j=1,3
6289           x_prime(j) = 0.00
6290           y_prime(j) = 0.00
6291           z_prime(j) = 0.00
6292         enddo
6293 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6294 !     &   dc_norm(3,i+nres)
6295         do j = 1,3
6296           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6297           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6298         enddo
6299         do j = 1,3
6300           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6301         enddo
6302 !       write (2,*) "i",i
6303 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6304 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6305 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6306 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6307 !      & " xy",scalar(x_prime(1),y_prime(1)),
6308 !      & " xz",scalar(x_prime(1),z_prime(1)),
6309 !      & " yy",scalar(y_prime(1),y_prime(1)),
6310 !      & " yz",scalar(y_prime(1),z_prime(1)),
6311 !      & " zz",scalar(z_prime(1),z_prime(1))
6312 !
6313 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6314 ! to local coordinate system. Store in xx, yy, zz.
6315 !
6316         xx=0.0d0
6317         yy=0.0d0
6318         zz=0.0d0
6319         do j = 1,3
6320           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6321           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6322           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6323         enddo
6324
6325         xxtab(i)=xx
6326         yytab(i)=yy
6327         zztab(i)=zz
6328 !
6329 ! Compute the energy of the ith side cbain
6330 !
6331 !        write (2,*) "xx",xx," yy",yy," zz",zz
6332         it=iabs(itype(i,1))
6333         do j = 1,65
6334           x(j) = sc_parmin(j,it)
6335         enddo
6336 #ifdef CHECK_COORD
6337 !c diagnostics - remove later
6338         xx1 = dcos(alph(2))
6339         yy1 = dsin(alph(2))*dcos(omeg(2))
6340         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6341         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6342           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6343           xx1,yy1,zz1
6344 !,"  --- ", xx_w,yy_w,zz_w
6345 ! end diagnostics
6346 #endif
6347         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6348          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6349          + x(10)*yy*zz
6350         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6351          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6352          + x(20)*yy*zz
6353         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6354          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6355          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6356          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6357          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6358          +x(40)*xx*yy*zz
6359         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6360          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6361          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6362          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6363          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6364          +x(60)*xx*yy*zz
6365         dsc_i   = 0.743d0+x(61)
6366         dp2_i   = 1.9d0+x(62)
6367         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6368                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6369         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6370                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6371         s1=(1+x(63))/(0.1d0 + dscp1)
6372         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6373         s2=(1+x(65))/(0.1d0 + dscp2)
6374         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6375         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6376       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6377 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6378 !     &   sumene4,
6379 !     &   dscp1,dscp2,sumene
6380 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6381         escloc = escloc + sumene
6382 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6383 !     & ,zz,xx,yy
6384 !#define DEBUG
6385 #ifdef DEBUG
6386 !
6387 ! This section to check the numerical derivatives of the energy of ith side
6388 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6389 ! #define DEBUG in the code to turn it on.
6390 !
6391         write (2,*) "sumene               =",sumene
6392         aincr=1.0d-7
6393         xxsave=xx
6394         xx=xx+aincr
6395         write (2,*) xx,yy,zz
6396         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6397         de_dxx_num=(sumenep-sumene)/aincr
6398         xx=xxsave
6399         write (2,*) "xx+ sumene from enesc=",sumenep
6400         yysave=yy
6401         yy=yy+aincr
6402         write (2,*) xx,yy,zz
6403         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6404         de_dyy_num=(sumenep-sumene)/aincr
6405         yy=yysave
6406         write (2,*) "yy+ sumene from enesc=",sumenep
6407         zzsave=zz
6408         zz=zz+aincr
6409         write (2,*) xx,yy,zz
6410         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6411         de_dzz_num=(sumenep-sumene)/aincr
6412         zz=zzsave
6413         write (2,*) "zz+ sumene from enesc=",sumenep
6414         costsave=cost2tab(i+1)
6415         sintsave=sint2tab(i+1)
6416         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6417         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6418         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6419         de_dt_num=(sumenep-sumene)/aincr
6420         write (2,*) " t+ sumene from enesc=",sumenep
6421         cost2tab(i+1)=costsave
6422         sint2tab(i+1)=sintsave
6423 ! End of diagnostics section.
6424 #endif
6425 !
6426 ! Compute the gradient of esc
6427 !
6428 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6429         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6430         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6431         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6432         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6433         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6434         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6435         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6436         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6437         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6438            *(pom_s1/dscp1+pom_s16*dscp1**4)
6439         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6440            *(pom_s2/dscp2+pom_s26*dscp2**4)
6441         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6442         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6443         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6444         +x(40)*yy*zz
6445         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6446         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6447         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6448         +x(60)*yy*zz
6449         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6450               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6451               +(pom1+pom2)*pom_dx
6452 #ifdef DEBUG
6453         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6454 #endif
6455 !
6456         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6457         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6458         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6459         +x(40)*xx*zz
6460         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6461         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6462         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6463         +x(59)*zz**2 +x(60)*xx*zz
6464         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6465               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6466               +(pom1-pom2)*pom_dy
6467 #ifdef DEBUG
6468         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6469 #endif
6470 !
6471         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6472         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6473         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6474         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6475         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6476         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6477         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6478         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6479 #ifdef DEBUG
6480         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6481 #endif
6482 !
6483         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6484         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6485         +pom1*pom_dt1+pom2*pom_dt2
6486 #ifdef DEBUG
6487         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6488 #endif
6489 !
6490 !
6491        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6492        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6493        cosfac2xx=cosfac2*xx
6494        sinfac2yy=sinfac2*yy
6495        do k = 1,3
6496          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6497             vbld_inv(i+1)
6498          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6499             vbld_inv(i)
6500          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6501          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6502 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6503 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6504 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6505 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6506          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6507          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6508          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6509          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6510          dZZ_Ci1(k)=0.0d0
6511          dZZ_Ci(k)=0.0d0
6512          do j=1,3
6513            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6514            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6515            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6516            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6517          enddo
6518
6519          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6520          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6521          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6522          (z_prime(k)-zz*dC_norm(k,i+nres))
6523 !
6524          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6525          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6526        enddo
6527
6528        do k=1,3
6529          dXX_Ctab(k,i)=dXX_Ci(k)
6530          dXX_C1tab(k,i)=dXX_Ci1(k)
6531          dYY_Ctab(k,i)=dYY_Ci(k)
6532          dYY_C1tab(k,i)=dYY_Ci1(k)
6533          dZZ_Ctab(k,i)=dZZ_Ci(k)
6534          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6535          dXX_XYZtab(k,i)=dXX_XYZ(k)
6536          dYY_XYZtab(k,i)=dYY_XYZ(k)
6537          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6538        enddo
6539
6540        do k = 1,3
6541 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6542 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6543 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6544 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6545 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6546 !     &    dt_dci(k)
6547 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6548 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6549          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6550           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6551          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6552           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6553          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6554           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6555        enddo
6556 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6557 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6558
6559 ! to check gradient call subroutine check_grad
6560
6561     1 continue
6562       enddo
6563       return
6564       end subroutine esc
6565 !-----------------------------------------------------------------------------
6566       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6567 !      implicit none
6568       real(kind=8),dimension(65) :: x
6569       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6570         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6571
6572       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6573         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6574         + x(10)*yy*zz
6575       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6576         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6577         + x(20)*yy*zz
6578       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6579         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6580         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6581         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6582         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6583         +x(40)*xx*yy*zz
6584       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6585         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6586         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6587         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6588         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6589         +x(60)*xx*yy*zz
6590       dsc_i   = 0.743d0+x(61)
6591       dp2_i   = 1.9d0+x(62)
6592       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6593                 *(xx*cost2+yy*sint2))
6594       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6595                 *(xx*cost2-yy*sint2))
6596       s1=(1+x(63))/(0.1d0 + dscp1)
6597       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6598       s2=(1+x(65))/(0.1d0 + dscp2)
6599       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6600       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6601        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6602       enesc=sumene
6603       return
6604       end function enesc
6605 #endif
6606 !-----------------------------------------------------------------------------
6607       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6608 !
6609 ! This procedure calculates two-body contact function g(rij) and its derivative:
6610 !
6611 !           eps0ij                                     !       x < -1
6612 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6613 !            0                                         !       x > 1
6614 !
6615 ! where x=(rij-r0ij)/delta
6616 !
6617 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6618 !
6619 !      implicit none
6620       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6621       real(kind=8) :: x,x2,x4,delta
6622 !     delta=0.02D0*r0ij
6623 !      delta=0.2D0*r0ij
6624       x=(rij-r0ij)/delta
6625       if (x.lt.-1.0D0) then
6626         fcont=eps0ij
6627         fprimcont=0.0D0
6628       else if (x.le.1.0D0) then
6629         x2=x*x
6630         x4=x2*x2
6631         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6632         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6633       else
6634         fcont=0.0D0
6635         fprimcont=0.0D0
6636       endif
6637       return
6638       end subroutine gcont
6639 !-----------------------------------------------------------------------------
6640       subroutine splinthet(theti,delta,ss,ssder)
6641 !      implicit real*8 (a-h,o-z)
6642 !      include 'DIMENSIONS'
6643 !      include 'COMMON.VAR'
6644 !      include 'COMMON.GEO'
6645       real(kind=8) :: theti,delta,ss,ssder
6646       real(kind=8) :: thetup,thetlow
6647       thetup=pi-delta
6648       thetlow=delta
6649       if (theti.gt.pipol) then
6650         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6651       else
6652         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6653         ssder=-ssder
6654       endif
6655       return
6656       end subroutine splinthet
6657 !-----------------------------------------------------------------------------
6658       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6659 !      implicit none
6660       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6661       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6662       a1=fprim0*delta/(f1-f0)
6663       a2=3.0d0-2.0d0*a1
6664       a3=a1-2.0d0
6665       ksi=(x-x0)/delta
6666       ksi2=ksi*ksi
6667       ksi3=ksi2*ksi
6668       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6669       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6670       return
6671       end subroutine spline1
6672 !-----------------------------------------------------------------------------
6673       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6674 !      implicit none
6675       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6676       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6677       ksi=(x-x0)/delta
6678       ksi2=ksi*ksi
6679       ksi3=ksi2*ksi
6680       a1=fprim0x*delta
6681       a2=3*(f1x-f0x)-2*fprim0x*delta
6682       a3=fprim0x*delta-2*(f1x-f0x)
6683       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6684       return
6685       end subroutine spline2
6686 !-----------------------------------------------------------------------------
6687 #ifdef CRYST_TOR
6688 !-----------------------------------------------------------------------------
6689       subroutine etor(etors,edihcnstr)
6690 !      implicit real*8 (a-h,o-z)
6691 !      include 'DIMENSIONS'
6692 !      include 'COMMON.VAR'
6693 !      include 'COMMON.GEO'
6694 !      include 'COMMON.LOCAL'
6695 !      include 'COMMON.TORSION'
6696 !      include 'COMMON.INTERACT'
6697 !      include 'COMMON.DERIV'
6698 !      include 'COMMON.CHAIN'
6699 !      include 'COMMON.NAMES'
6700 !      include 'COMMON.IOUNITS'
6701 !      include 'COMMON.FFIELD'
6702 !      include 'COMMON.TORCNSTR'
6703 !      include 'COMMON.CONTROL'
6704       real(kind=8) :: etors,edihcnstr
6705       logical :: lprn
6706 !el local variables
6707       integer :: i,j,
6708       real(kind=8) :: phii,fac,etors_ii
6709
6710 ! Set lprn=.true. for debugging
6711       lprn=.false.
6712 !      lprn=.true.
6713       etors=0.0D0
6714       do i=iphi_start,iphi_end
6715       etors_ii=0.0D0
6716         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6717             .or. itype(i,1).eq.ntyp1) cycle
6718         itori=itortyp(itype(i-2,1))
6719         itori1=itortyp(itype(i-1,1))
6720         phii=phi(i)
6721         gloci=0.0D0
6722 ! Proline-Proline pair is a special case...
6723         if (itori.eq.3 .and. itori1.eq.3) then
6724           if (phii.gt.-dwapi3) then
6725             cosphi=dcos(3*phii)
6726             fac=1.0D0/(1.0D0-cosphi)
6727             etorsi=v1(1,3,3)*fac
6728             etorsi=etorsi+etorsi
6729             etors=etors+etorsi-v1(1,3,3)
6730             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6731             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6732           endif
6733           do j=1,3
6734             v1ij=v1(j+1,itori,itori1)
6735             v2ij=v2(j+1,itori,itori1)
6736             cosphi=dcos(j*phii)
6737             sinphi=dsin(j*phii)
6738             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6739             if (energy_dec) etors_ii=etors_ii+ &
6740                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6741             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6742           enddo
6743         else
6744           do j=1,nterm_old
6745             v1ij=v1(j,itori,itori1)
6746             v2ij=v2(j,itori,itori1)
6747             cosphi=dcos(j*phii)
6748             sinphi=dsin(j*phii)
6749             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6750             if (energy_dec) etors_ii=etors_ii+ &
6751                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6752             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6753           enddo
6754         endif
6755         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6756              'etor',i,etors_ii
6757         if (lprn) &
6758         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6759         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6760         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6761         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6762 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6763       enddo
6764 ! 6/20/98 - dihedral angle constraints
6765       edihcnstr=0.0d0
6766       do i=1,ndih_constr
6767         itori=idih_constr(i)
6768         phii=phi(itori)
6769         difi=phii-phi0(i)
6770         if (difi.gt.drange(i)) then
6771           difi=difi-drange(i)
6772           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6773           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6774         else if (difi.lt.-drange(i)) then
6775           difi=difi+drange(i)
6776           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6777           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6778         endif
6779 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6780 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6781       enddo
6782 !      write (iout,*) 'edihcnstr',edihcnstr
6783       return
6784       end subroutine etor
6785 !-----------------------------------------------------------------------------
6786       subroutine etor_d(etors_d)
6787       real(kind=8) :: etors_d
6788       etors_d=0.0d0
6789       return
6790       end subroutine etor_d
6791 #else
6792 !-----------------------------------------------------------------------------
6793       subroutine etor(etors,edihcnstr)
6794 !      implicit real*8 (a-h,o-z)
6795 !      include 'DIMENSIONS'
6796 !      include 'COMMON.VAR'
6797 !      include 'COMMON.GEO'
6798 !      include 'COMMON.LOCAL'
6799 !      include 'COMMON.TORSION'
6800 !      include 'COMMON.INTERACT'
6801 !      include 'COMMON.DERIV'
6802 !      include 'COMMON.CHAIN'
6803 !      include 'COMMON.NAMES'
6804 !      include 'COMMON.IOUNITS'
6805 !      include 'COMMON.FFIELD'
6806 !      include 'COMMON.TORCNSTR'
6807 !      include 'COMMON.CONTROL'
6808       real(kind=8) :: etors,edihcnstr
6809       logical :: lprn
6810 !el local variables
6811       integer :: i,j,iblock,itori,itori1
6812       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6813                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6814 ! Set lprn=.true. for debugging
6815       lprn=.false.
6816 !     lprn=.true.
6817       etors=0.0D0
6818       do i=iphi_start,iphi_end
6819         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6820              .or. itype(i-3,1).eq.ntyp1 &
6821              .or. itype(i,1).eq.ntyp1) cycle
6822         etors_ii=0.0D0
6823          if (iabs(itype(i,1)).eq.20) then
6824          iblock=2
6825          else
6826          iblock=1
6827          endif
6828         itori=itortyp(itype(i-2,1))
6829         itori1=itortyp(itype(i-1,1))
6830         phii=phi(i)
6831         gloci=0.0D0
6832 ! Regular cosine and sine terms
6833         do j=1,nterm(itori,itori1,iblock)
6834           v1ij=v1(j,itori,itori1,iblock)
6835           v2ij=v2(j,itori,itori1,iblock)
6836           cosphi=dcos(j*phii)
6837           sinphi=dsin(j*phii)
6838           etors=etors+v1ij*cosphi+v2ij*sinphi
6839           if (energy_dec) etors_ii=etors_ii+ &
6840                      v1ij*cosphi+v2ij*sinphi
6841           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6842         enddo
6843 ! Lorentz terms
6844 !                         v1
6845 !  E = SUM ----------------------------------- - v1
6846 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6847 !
6848         cosphi=dcos(0.5d0*phii)
6849         sinphi=dsin(0.5d0*phii)
6850         do j=1,nlor(itori,itori1,iblock)
6851           vl1ij=vlor1(j,itori,itori1)
6852           vl2ij=vlor2(j,itori,itori1)
6853           vl3ij=vlor3(j,itori,itori1)
6854           pom=vl2ij*cosphi+vl3ij*sinphi
6855           pom1=1.0d0/(pom*pom+1.0d0)
6856           etors=etors+vl1ij*pom1
6857           if (energy_dec) etors_ii=etors_ii+ &
6858                      vl1ij*pom1
6859           pom=-pom*pom1*pom1
6860           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6861         enddo
6862 ! Subtract the constant term
6863         etors=etors-v0(itori,itori1,iblock)
6864           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6865                'etor',i,etors_ii-v0(itori,itori1,iblock)
6866         if (lprn) &
6867         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6868         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6869         (v1(j,itori,itori1,iblock),j=1,6),&
6870         (v2(j,itori,itori1,iblock),j=1,6)
6871         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6872 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6873       enddo
6874 ! 6/20/98 - dihedral angle constraints
6875       edihcnstr=0.0d0
6876 !      do i=1,ndih_constr
6877       do i=idihconstr_start,idihconstr_end
6878         itori=idih_constr(i)
6879         phii=phi(itori)
6880         difi=pinorm(phii-phi0(i))
6881         if (difi.gt.drange(i)) then
6882           difi=difi-drange(i)
6883           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6884           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6885         else if (difi.lt.-drange(i)) then
6886           difi=difi+drange(i)
6887           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6888           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6889         else
6890           difi=0.0
6891         endif
6892 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6893 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6894 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6895       enddo
6896 !d       write (iout,*) 'edihcnstr',edihcnstr
6897       return
6898       end subroutine etor
6899 !-----------------------------------------------------------------------------
6900       subroutine etor_d(etors_d)
6901 ! 6/23/01 Compute double torsional energy
6902 !      implicit real*8 (a-h,o-z)
6903 !      include 'DIMENSIONS'
6904 !      include 'COMMON.VAR'
6905 !      include 'COMMON.GEO'
6906 !      include 'COMMON.LOCAL'
6907 !      include 'COMMON.TORSION'
6908 !      include 'COMMON.INTERACT'
6909 !      include 'COMMON.DERIV'
6910 !      include 'COMMON.CHAIN'
6911 !      include 'COMMON.NAMES'
6912 !      include 'COMMON.IOUNITS'
6913 !      include 'COMMON.FFIELD'
6914 !      include 'COMMON.TORCNSTR'
6915       real(kind=8) :: etors_d,etors_d_ii
6916       logical :: lprn
6917 !el local variables
6918       integer :: i,j,k,l,itori,itori1,itori2,iblock
6919       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6920                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6921                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6922                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6923 ! Set lprn=.true. for debugging
6924       lprn=.false.
6925 !     lprn=.true.
6926       etors_d=0.0D0
6927 !      write(iout,*) "a tu??"
6928       do i=iphid_start,iphid_end
6929         etors_d_ii=0.0D0
6930         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6931             .or. itype(i-3,1).eq.ntyp1 &
6932             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6933         itori=itortyp(itype(i-2,1))
6934         itori1=itortyp(itype(i-1,1))
6935         itori2=itortyp(itype(i,1))
6936         phii=phi(i)
6937         phii1=phi(i+1)
6938         gloci1=0.0D0
6939         gloci2=0.0D0
6940         iblock=1
6941         if (iabs(itype(i+1,1)).eq.20) iblock=2
6942
6943 ! Regular cosine and sine terms
6944         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6945           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6946           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6947           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6948           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6949           cosphi1=dcos(j*phii)
6950           sinphi1=dsin(j*phii)
6951           cosphi2=dcos(j*phii1)
6952           sinphi2=dsin(j*phii1)
6953           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6954            v2cij*cosphi2+v2sij*sinphi2
6955           if (energy_dec) etors_d_ii=etors_d_ii+ &
6956            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6957           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6958           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6959         enddo
6960         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6961           do l=1,k-1
6962             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6963             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6964             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6965             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6966             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6967             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6968             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6969             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6970             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6971               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6972             if (energy_dec) etors_d_ii=etors_d_ii+ &
6973               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6974               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6975             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6976               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6977             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6978               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6979           enddo
6980         enddo
6981         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6982                             'etor_d',i,etors_d_ii
6983         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6984         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6985       enddo
6986       return
6987       end subroutine etor_d
6988 #endif
6989 !-----------------------------------------------------------------------------
6990       subroutine eback_sc_corr(esccor)
6991 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6992 !        conformational states; temporarily implemented as differences
6993 !        between UNRES torsional potentials (dependent on three types of
6994 !        residues) and the torsional potentials dependent on all 20 types
6995 !        of residues computed from AM1  energy surfaces of terminally-blocked
6996 !        amino-acid residues.
6997 !      implicit real*8 (a-h,o-z)
6998 !      include 'DIMENSIONS'
6999 !      include 'COMMON.VAR'
7000 !      include 'COMMON.GEO'
7001 !      include 'COMMON.LOCAL'
7002 !      include 'COMMON.TORSION'
7003 !      include 'COMMON.SCCOR'
7004 !      include 'COMMON.INTERACT'
7005 !      include 'COMMON.DERIV'
7006 !      include 'COMMON.CHAIN'
7007 !      include 'COMMON.NAMES'
7008 !      include 'COMMON.IOUNITS'
7009 !      include 'COMMON.FFIELD'
7010 !      include 'COMMON.CONTROL'
7011       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7012                    cosphi,sinphi
7013       logical :: lprn
7014       integer :: i,interty,j,isccori,isccori1,intertyp
7015 ! Set lprn=.true. for debugging
7016       lprn=.false.
7017 !      lprn=.true.
7018 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7019       esccor=0.0D0
7020       do i=itau_start,itau_end
7021         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7022         esccor_ii=0.0D0
7023         isccori=isccortyp(itype(i-2,1))
7024         isccori1=isccortyp(itype(i-1,1))
7025
7026 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7027         phii=phi(i)
7028         do intertyp=1,3 !intertyp
7029          esccor_ii=0.0D0
7030 !c Added 09 May 2012 (Adasko)
7031 !c  Intertyp means interaction type of backbone mainchain correlation:
7032 !   1 = SC...Ca...Ca...Ca
7033 !   2 = Ca...Ca...Ca...SC
7034 !   3 = SC...Ca...Ca...SCi
7035         gloci=0.0D0
7036         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7037             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7038             (itype(i-1,1).eq.ntyp1))) &
7039           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7040            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7041            .or.(itype(i,1).eq.ntyp1))) &
7042           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7043             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7044             (itype(i-3,1).eq.ntyp1)))) cycle
7045         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7046         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7047        cycle
7048        do j=1,nterm_sccor(isccori,isccori1)
7049           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7050           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7051           cosphi=dcos(j*tauangle(intertyp,i))
7052           sinphi=dsin(j*tauangle(intertyp,i))
7053           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7054           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7055           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7056         enddo
7057         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7058                                 'esccor',i,intertyp,esccor_ii
7059 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7060         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7061         if (lprn) &
7062         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7063         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7064         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7065         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7066         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7067        enddo !intertyp
7068       enddo
7069
7070       return
7071       end subroutine eback_sc_corr
7072 !-----------------------------------------------------------------------------
7073       subroutine multibody(ecorr)
7074 ! This subroutine calculates multi-body contributions to energy following
7075 ! the idea of Skolnick et al. If side chains I and J make a contact and
7076 ! at the same time side chains I+1 and J+1 make a contact, an extra
7077 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7078 !      implicit real*8 (a-h,o-z)
7079 !      include 'DIMENSIONS'
7080 !      include 'COMMON.IOUNITS'
7081 !      include 'COMMON.DERIV'
7082 !      include 'COMMON.INTERACT'
7083 !      include 'COMMON.CONTACTS'
7084       real(kind=8),dimension(3) :: gx,gx1
7085       logical :: lprn
7086       real(kind=8) :: ecorr
7087       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7088 ! Set lprn=.true. for debugging
7089       lprn=.false.
7090
7091       if (lprn) then
7092         write (iout,'(a)') 'Contact function values:'
7093         do i=nnt,nct-2
7094           write (iout,'(i2,20(1x,i2,f10.5))') &
7095               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7096         enddo
7097       endif
7098       ecorr=0.0D0
7099
7100 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7101 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7102       do i=nnt,nct
7103         do j=1,3
7104           gradcorr(j,i)=0.0D0
7105           gradxorr(j,i)=0.0D0
7106         enddo
7107       enddo
7108       do i=nnt,nct-2
7109
7110         DO ISHIFT = 3,4
7111
7112         i1=i+ishift
7113         num_conti=num_cont(i)
7114         num_conti1=num_cont(i1)
7115         do jj=1,num_conti
7116           j=jcont(jj,i)
7117           do kk=1,num_conti1
7118             j1=jcont(kk,i1)
7119             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7120 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7121 !d   &                   ' ishift=',ishift
7122 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7123 ! The system gains extra energy.
7124               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7125             endif   ! j1==j+-ishift
7126           enddo     ! kk
7127         enddo       ! jj
7128
7129         ENDDO ! ISHIFT
7130
7131       enddo         ! i
7132       return
7133       end subroutine multibody
7134 !-----------------------------------------------------------------------------
7135       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7136 !      implicit real*8 (a-h,o-z)
7137 !      include 'DIMENSIONS'
7138 !      include 'COMMON.IOUNITS'
7139 !      include 'COMMON.DERIV'
7140 !      include 'COMMON.INTERACT'
7141 !      include 'COMMON.CONTACTS'
7142       real(kind=8),dimension(3) :: gx,gx1
7143       logical :: lprn
7144       integer :: i,j,k,l,jj,kk,m,ll
7145       real(kind=8) :: eij,ekl
7146       lprn=.false.
7147       eij=facont(jj,i)
7148       ekl=facont(kk,k)
7149 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7150 ! Calculate the multi-body contribution to energy.
7151 ! Calculate multi-body contributions to the gradient.
7152 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7153 !d   & k,l,(gacont(m,kk,k),m=1,3)
7154       do m=1,3
7155         gx(m) =ekl*gacont(m,jj,i)
7156         gx1(m)=eij*gacont(m,kk,k)
7157         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7158         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7159         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7160         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7161       enddo
7162       do m=i,j-1
7163         do ll=1,3
7164           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7165         enddo
7166       enddo
7167       do m=k,l-1
7168         do ll=1,3
7169           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7170         enddo
7171       enddo
7172       esccorr=-eij*ekl
7173       return
7174       end function esccorr
7175 !-----------------------------------------------------------------------------
7176       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7177 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7178 !      implicit real*8 (a-h,o-z)
7179 !      include 'DIMENSIONS'
7180 !      include 'COMMON.IOUNITS'
7181 #ifdef MPI
7182       include "mpif.h"
7183 !      integer :: maxconts !max_cont=maxconts  =nres/4
7184       integer,parameter :: max_dim=26
7185       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7186       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7187 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7188 !el      common /przechowalnia/ zapas
7189       integer :: status(MPI_STATUS_SIZE)
7190       integer,dimension((nres/4)*2) :: req !maxconts*2
7191       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7192 #endif
7193 !      include 'COMMON.SETUP'
7194 !      include 'COMMON.FFIELD'
7195 !      include 'COMMON.DERIV'
7196 !      include 'COMMON.INTERACT'
7197 !      include 'COMMON.CONTACTS'
7198 !      include 'COMMON.CONTROL'
7199 !      include 'COMMON.LOCAL'
7200       real(kind=8),dimension(3) :: gx,gx1
7201       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7202       logical :: lprn,ldone
7203 !el local variables
7204       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7205               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7206
7207 ! Set lprn=.true. for debugging
7208       lprn=.false.
7209 #ifdef MPI
7210 !      maxconts=nres/4
7211       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7212       n_corr=0
7213       n_corr1=0
7214       if (nfgtasks.le.1) goto 30
7215       if (lprn) then
7216         write (iout,'(a)') 'Contact function values before RECEIVE:'
7217         do i=nnt,nct-2
7218           write (iout,'(2i3,50(1x,i2,f5.2))') &
7219           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7220           j=1,num_cont_hb(i))
7221         enddo
7222       endif
7223       call flush(iout)
7224       do i=1,ntask_cont_from
7225         ncont_recv(i)=0
7226       enddo
7227       do i=1,ntask_cont_to
7228         ncont_sent(i)=0
7229       enddo
7230 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7231 !     & ntask_cont_to
7232 ! Make the list of contacts to send to send to other procesors
7233 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7234 !      call flush(iout)
7235       do i=iturn3_start,iturn3_end
7236 !        write (iout,*) "make contact list turn3",i," num_cont",
7237 !     &    num_cont_hb(i)
7238         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7239       enddo
7240       do i=iturn4_start,iturn4_end
7241 !        write (iout,*) "make contact list turn4",i," num_cont",
7242 !     &   num_cont_hb(i)
7243         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7244       enddo
7245       do ii=1,nat_sent
7246         i=iat_sent(ii)
7247 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7248 !     &    num_cont_hb(i)
7249         do j=1,num_cont_hb(i)
7250         do k=1,4
7251           jjc=jcont_hb(j,i)
7252           iproc=iint_sent_local(k,jjc,ii)
7253 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7254           if (iproc.gt.0) then
7255             ncont_sent(iproc)=ncont_sent(iproc)+1
7256             nn=ncont_sent(iproc)
7257             zapas(1,nn,iproc)=i
7258             zapas(2,nn,iproc)=jjc
7259             zapas(3,nn,iproc)=facont_hb(j,i)
7260             zapas(4,nn,iproc)=ees0p(j,i)
7261             zapas(5,nn,iproc)=ees0m(j,i)
7262             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7263             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7264             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7265             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7266             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7267             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7268             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7269             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7270             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7271             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7272             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7273             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7274             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7275             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7276             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7277             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7278             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7279             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7280             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7281             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7282             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7283           endif
7284         enddo
7285         enddo
7286       enddo
7287       if (lprn) then
7288       write (iout,*) &
7289         "Numbers of contacts to be sent to other processors",&
7290         (ncont_sent(i),i=1,ntask_cont_to)
7291       write (iout,*) "Contacts sent"
7292       do ii=1,ntask_cont_to
7293         nn=ncont_sent(ii)
7294         iproc=itask_cont_to(ii)
7295         write (iout,*) nn," contacts to processor",iproc,&
7296          " of CONT_TO_COMM group"
7297         do i=1,nn
7298           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7299         enddo
7300       enddo
7301       call flush(iout)
7302       endif
7303       CorrelType=477
7304       CorrelID=fg_rank+1
7305       CorrelType1=478
7306       CorrelID1=nfgtasks+fg_rank+1
7307       ireq=0
7308 ! Receive the numbers of needed contacts from other processors
7309       do ii=1,ntask_cont_from
7310         iproc=itask_cont_from(ii)
7311         ireq=ireq+1
7312         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7313           FG_COMM,req(ireq),IERR)
7314       enddo
7315 !      write (iout,*) "IRECV ended"
7316 !      call flush(iout)
7317 ! Send the number of contacts needed by other processors
7318       do ii=1,ntask_cont_to
7319         iproc=itask_cont_to(ii)
7320         ireq=ireq+1
7321         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7322           FG_COMM,req(ireq),IERR)
7323       enddo
7324 !      write (iout,*) "ISEND ended"
7325 !      write (iout,*) "number of requests (nn)",ireq
7326       call flush(iout)
7327       if (ireq.gt.0) &
7328         call MPI_Waitall(ireq,req,status_array,ierr)
7329 !      write (iout,*)
7330 !     &  "Numbers of contacts to be received from other processors",
7331 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7332 !      call flush(iout)
7333 ! Receive contacts
7334       ireq=0
7335       do ii=1,ntask_cont_from
7336         iproc=itask_cont_from(ii)
7337         nn=ncont_recv(ii)
7338 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7339 !     &   " of CONT_TO_COMM group"
7340         call flush(iout)
7341         if (nn.gt.0) then
7342           ireq=ireq+1
7343           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7344           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7345 !          write (iout,*) "ireq,req",ireq,req(ireq)
7346         endif
7347       enddo
7348 ! Send the contacts to processors that need them
7349       do ii=1,ntask_cont_to
7350         iproc=itask_cont_to(ii)
7351         nn=ncont_sent(ii)
7352 !        write (iout,*) nn," contacts to processor",iproc,
7353 !     &   " of CONT_TO_COMM group"
7354         if (nn.gt.0) then
7355           ireq=ireq+1
7356           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7357             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7358 !          write (iout,*) "ireq,req",ireq,req(ireq)
7359 !          do i=1,nn
7360 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7361 !          enddo
7362         endif
7363       enddo
7364 !      write (iout,*) "number of requests (contacts)",ireq
7365 !      write (iout,*) "req",(req(i),i=1,4)
7366 !      call flush(iout)
7367       if (ireq.gt.0) &
7368        call MPI_Waitall(ireq,req,status_array,ierr)
7369       do iii=1,ntask_cont_from
7370         iproc=itask_cont_from(iii)
7371         nn=ncont_recv(iii)
7372         if (lprn) then
7373         write (iout,*) "Received",nn," contacts from processor",iproc,&
7374          " of CONT_FROM_COMM group"
7375         call flush(iout)
7376         do i=1,nn
7377           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7378         enddo
7379         call flush(iout)
7380         endif
7381         do i=1,nn
7382           ii=zapas_recv(1,i,iii)
7383 ! Flag the received contacts to prevent double-counting
7384           jj=-zapas_recv(2,i,iii)
7385 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7386 !          call flush(iout)
7387           nnn=num_cont_hb(ii)+1
7388           num_cont_hb(ii)=nnn
7389           jcont_hb(nnn,ii)=jj
7390           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7391           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7392           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7393           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7394           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7395           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7396           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7397           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7398           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7399           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7400           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7401           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7402           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7403           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7404           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7405           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7406           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7407           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7408           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7409           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7410           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7411           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7412           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7413           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7414         enddo
7415       enddo
7416       call flush(iout)
7417       if (lprn) then
7418         write (iout,'(a)') 'Contact function values after receive:'
7419         do i=nnt,nct-2
7420           write (iout,'(2i3,50(1x,i3,f5.2))') &
7421           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7422           j=1,num_cont_hb(i))
7423         enddo
7424         call flush(iout)
7425       endif
7426    30 continue
7427 #endif
7428       if (lprn) then
7429         write (iout,'(a)') 'Contact function values:'
7430         do i=nnt,nct-2
7431           write (iout,'(2i3,50(1x,i3,f5.2))') &
7432           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7433           j=1,num_cont_hb(i))
7434         enddo
7435       endif
7436       ecorr=0.0D0
7437
7438 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7439 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7440 ! Remove the loop below after debugging !!!
7441       do i=nnt,nct
7442         do j=1,3
7443           gradcorr(j,i)=0.0D0
7444           gradxorr(j,i)=0.0D0
7445         enddo
7446       enddo
7447 ! Calculate the local-electrostatic correlation terms
7448       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7449         i1=i+1
7450         num_conti=num_cont_hb(i)
7451         num_conti1=num_cont_hb(i+1)
7452         do jj=1,num_conti
7453           j=jcont_hb(jj,i)
7454           jp=iabs(j)
7455           do kk=1,num_conti1
7456             j1=jcont_hb(kk,i1)
7457             jp1=iabs(j1)
7458 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7459 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7460             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7461                 .or. j.lt.0 .and. j1.gt.0) .and. &
7462                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7463 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7464 ! The system gains extra energy.
7465               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7466               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7467                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7468               n_corr=n_corr+1
7469             else if (j1.eq.j) then
7470 ! Contacts I-J and I-(J+1) occur simultaneously.
7471 ! The system loses extra energy.
7472 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7473             endif
7474           enddo ! kk
7475           do kk=1,num_conti
7476             j1=jcont_hb(kk,i)
7477 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7478 !    &         ' jj=',jj,' kk=',kk
7479             if (j1.eq.j+1) then
7480 ! Contacts I-J and (I+1)-J occur simultaneously.
7481 ! The system loses extra energy.
7482 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7483             endif ! j1==j+1
7484           enddo ! kk
7485         enddo ! jj
7486       enddo ! i
7487       return
7488       end subroutine multibody_hb
7489 !-----------------------------------------------------------------------------
7490       subroutine add_hb_contact(ii,jj,itask)
7491 !      implicit real*8 (a-h,o-z)
7492 !      include "DIMENSIONS"
7493 !      include "COMMON.IOUNITS"
7494 !      include "COMMON.CONTACTS"
7495 !      integer,parameter :: maxconts=nres/4
7496       integer,parameter :: max_dim=26
7497       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7498 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7499 !      common /przechowalnia/ zapas
7500       integer :: i,j,ii,jj,iproc,nn,jjc
7501       integer,dimension(4) :: itask
7502 !      write (iout,*) "itask",itask
7503       do i=1,2
7504         iproc=itask(i)
7505         if (iproc.gt.0) then
7506           do j=1,num_cont_hb(ii)
7507             jjc=jcont_hb(j,ii)
7508 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7509             if (jjc.eq.jj) then
7510               ncont_sent(iproc)=ncont_sent(iproc)+1
7511               nn=ncont_sent(iproc)
7512               zapas(1,nn,iproc)=ii
7513               zapas(2,nn,iproc)=jjc
7514               zapas(3,nn,iproc)=facont_hb(j,ii)
7515               zapas(4,nn,iproc)=ees0p(j,ii)
7516               zapas(5,nn,iproc)=ees0m(j,ii)
7517               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7518               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7519               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7520               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7521               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7522               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7523               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7524               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7525               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7526               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7527               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7528               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7529               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7530               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7531               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7532               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7533               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7534               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7535               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7536               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7537               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7538               exit
7539             endif
7540           enddo
7541         endif
7542       enddo
7543       return
7544       end subroutine add_hb_contact
7545 !-----------------------------------------------------------------------------
7546       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7547 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7548 !      implicit real*8 (a-h,o-z)
7549 !      include 'DIMENSIONS'
7550 !      include 'COMMON.IOUNITS'
7551       integer,parameter :: max_dim=70
7552 #ifdef MPI
7553       include "mpif.h"
7554 !      integer :: maxconts !max_cont=maxconts=nres/4
7555       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7556       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7557 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7558 !      common /przechowalnia/ zapas
7559       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7560         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7561         ierr,iii,nnn
7562 #endif
7563 !      include 'COMMON.SETUP'
7564 !      include 'COMMON.FFIELD'
7565 !      include 'COMMON.DERIV'
7566 !      include 'COMMON.LOCAL'
7567 !      include 'COMMON.INTERACT'
7568 !      include 'COMMON.CONTACTS'
7569 !      include 'COMMON.CHAIN'
7570 !      include 'COMMON.CONTROL'
7571       real(kind=8),dimension(3) :: gx,gx1
7572       integer,dimension(nres) :: num_cont_hb_old
7573       logical :: lprn,ldone
7574 !EL      double precision eello4,eello5,eelo6,eello_turn6
7575 !EL      external eello4,eello5,eello6,eello_turn6
7576 !el local variables
7577       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7578               j1,jp1,i1,num_conti1
7579       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7580       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7581
7582 ! Set lprn=.true. for debugging
7583       lprn=.false.
7584       eturn6=0.0d0
7585 #ifdef MPI
7586 !      maxconts=nres/4
7587       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7588       do i=1,nres
7589         num_cont_hb_old(i)=num_cont_hb(i)
7590       enddo
7591       n_corr=0
7592       n_corr1=0
7593       if (nfgtasks.le.1) goto 30
7594       if (lprn) then
7595         write (iout,'(a)') 'Contact function values before RECEIVE:'
7596         do i=nnt,nct-2
7597           write (iout,'(2i3,50(1x,i2,f5.2))') &
7598           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7599           j=1,num_cont_hb(i))
7600         enddo
7601       endif
7602       call flush(iout)
7603       do i=1,ntask_cont_from
7604         ncont_recv(i)=0
7605       enddo
7606       do i=1,ntask_cont_to
7607         ncont_sent(i)=0
7608       enddo
7609 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7610 !     & ntask_cont_to
7611 ! Make the list of contacts to send to send to other procesors
7612       do i=iturn3_start,iturn3_end
7613 !        write (iout,*) "make contact list turn3",i," num_cont",
7614 !     &    num_cont_hb(i)
7615         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7616       enddo
7617       do i=iturn4_start,iturn4_end
7618 !        write (iout,*) "make contact list turn4",i," num_cont",
7619 !     &   num_cont_hb(i)
7620         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7621       enddo
7622       do ii=1,nat_sent
7623         i=iat_sent(ii)
7624 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7625 !     &    num_cont_hb(i)
7626         do j=1,num_cont_hb(i)
7627         do k=1,4
7628           jjc=jcont_hb(j,i)
7629           iproc=iint_sent_local(k,jjc,ii)
7630 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7631           if (iproc.ne.0) then
7632             ncont_sent(iproc)=ncont_sent(iproc)+1
7633             nn=ncont_sent(iproc)
7634             zapas(1,nn,iproc)=i
7635             zapas(2,nn,iproc)=jjc
7636             zapas(3,nn,iproc)=d_cont(j,i)
7637             ind=3
7638             do kk=1,3
7639               ind=ind+1
7640               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7641             enddo
7642             do kk=1,2
7643               do ll=1,2
7644                 ind=ind+1
7645                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7646               enddo
7647             enddo
7648             do jj=1,5
7649               do kk=1,3
7650                 do ll=1,2
7651                   do mm=1,2
7652                     ind=ind+1
7653                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7654                   enddo
7655                 enddo
7656               enddo
7657             enddo
7658           endif
7659         enddo
7660         enddo
7661       enddo
7662       if (lprn) then
7663       write (iout,*) &
7664         "Numbers of contacts to be sent to other processors",&
7665         (ncont_sent(i),i=1,ntask_cont_to)
7666       write (iout,*) "Contacts sent"
7667       do ii=1,ntask_cont_to
7668         nn=ncont_sent(ii)
7669         iproc=itask_cont_to(ii)
7670         write (iout,*) nn," contacts to processor",iproc,&
7671          " of CONT_TO_COMM group"
7672         do i=1,nn
7673           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7674         enddo
7675       enddo
7676       call flush(iout)
7677       endif
7678       CorrelType=477
7679       CorrelID=fg_rank+1
7680       CorrelType1=478
7681       CorrelID1=nfgtasks+fg_rank+1
7682       ireq=0
7683 ! Receive the numbers of needed contacts from other processors
7684       do ii=1,ntask_cont_from
7685         iproc=itask_cont_from(ii)
7686         ireq=ireq+1
7687         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7688           FG_COMM,req(ireq),IERR)
7689       enddo
7690 !      write (iout,*) "IRECV ended"
7691 !      call flush(iout)
7692 ! Send the number of contacts needed by other processors
7693       do ii=1,ntask_cont_to
7694         iproc=itask_cont_to(ii)
7695         ireq=ireq+1
7696         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7697           FG_COMM,req(ireq),IERR)
7698       enddo
7699 !      write (iout,*) "ISEND ended"
7700 !      write (iout,*) "number of requests (nn)",ireq
7701       call flush(iout)
7702       if (ireq.gt.0) &
7703         call MPI_Waitall(ireq,req,status_array,ierr)
7704 !      write (iout,*)
7705 !     &  "Numbers of contacts to be received from other processors",
7706 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7707 !      call flush(iout)
7708 ! Receive contacts
7709       ireq=0
7710       do ii=1,ntask_cont_from
7711         iproc=itask_cont_from(ii)
7712         nn=ncont_recv(ii)
7713 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7714 !     &   " of CONT_TO_COMM group"
7715         call flush(iout)
7716         if (nn.gt.0) then
7717           ireq=ireq+1
7718           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7719           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7720 !          write (iout,*) "ireq,req",ireq,req(ireq)
7721         endif
7722       enddo
7723 ! Send the contacts to processors that need them
7724       do ii=1,ntask_cont_to
7725         iproc=itask_cont_to(ii)
7726         nn=ncont_sent(ii)
7727 !        write (iout,*) nn," contacts to processor",iproc,
7728 !     &   " of CONT_TO_COMM group"
7729         if (nn.gt.0) then
7730           ireq=ireq+1
7731           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7732             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7733 !          write (iout,*) "ireq,req",ireq,req(ireq)
7734 !          do i=1,nn
7735 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7736 !          enddo
7737         endif
7738       enddo
7739 !      write (iout,*) "number of requests (contacts)",ireq
7740 !      write (iout,*) "req",(req(i),i=1,4)
7741 !      call flush(iout)
7742       if (ireq.gt.0) &
7743        call MPI_Waitall(ireq,req,status_array,ierr)
7744       do iii=1,ntask_cont_from
7745         iproc=itask_cont_from(iii)
7746         nn=ncont_recv(iii)
7747         if (lprn) then
7748         write (iout,*) "Received",nn," contacts from processor",iproc,&
7749          " of CONT_FROM_COMM group"
7750         call flush(iout)
7751         do i=1,nn
7752           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7753         enddo
7754         call flush(iout)
7755         endif
7756         do i=1,nn
7757           ii=zapas_recv(1,i,iii)
7758 ! Flag the received contacts to prevent double-counting
7759           jj=-zapas_recv(2,i,iii)
7760 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7761 !          call flush(iout)
7762           nnn=num_cont_hb(ii)+1
7763           num_cont_hb(ii)=nnn
7764           jcont_hb(nnn,ii)=jj
7765           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7766           ind=3
7767           do kk=1,3
7768             ind=ind+1
7769             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7770           enddo
7771           do kk=1,2
7772             do ll=1,2
7773               ind=ind+1
7774               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7775             enddo
7776           enddo
7777           do jj=1,5
7778             do kk=1,3
7779               do ll=1,2
7780                 do mm=1,2
7781                   ind=ind+1
7782                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7783                 enddo
7784               enddo
7785             enddo
7786           enddo
7787         enddo
7788       enddo
7789       call flush(iout)
7790       if (lprn) then
7791         write (iout,'(a)') 'Contact function values after receive:'
7792         do i=nnt,nct-2
7793           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7794           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7795           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7796         enddo
7797         call flush(iout)
7798       endif
7799    30 continue
7800 #endif
7801       if (lprn) then
7802         write (iout,'(a)') 'Contact function values:'
7803         do i=nnt,nct-2
7804           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7805           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7806           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7807         enddo
7808       endif
7809       ecorr=0.0D0
7810       ecorr5=0.0d0
7811       ecorr6=0.0d0
7812
7813 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7814 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7815 ! Remove the loop below after debugging !!!
7816       do i=nnt,nct
7817         do j=1,3
7818           gradcorr(j,i)=0.0D0
7819           gradxorr(j,i)=0.0D0
7820         enddo
7821       enddo
7822 ! Calculate the dipole-dipole interaction energies
7823       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7824       do i=iatel_s,iatel_e+1
7825         num_conti=num_cont_hb(i)
7826         do jj=1,num_conti
7827           j=jcont_hb(jj,i)
7828 #ifdef MOMENT
7829           call dipole(i,j,jj)
7830 #endif
7831         enddo
7832       enddo
7833       endif
7834 ! Calculate the local-electrostatic correlation terms
7835 !                write (iout,*) "gradcorr5 in eello5 before loop"
7836 !                do iii=1,nres
7837 !                  write (iout,'(i5,3f10.5)')
7838 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7839 !                enddo
7840       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7841 !        write (iout,*) "corr loop i",i
7842         i1=i+1
7843         num_conti=num_cont_hb(i)
7844         num_conti1=num_cont_hb(i+1)
7845         do jj=1,num_conti
7846           j=jcont_hb(jj,i)
7847           jp=iabs(j)
7848           do kk=1,num_conti1
7849             j1=jcont_hb(kk,i1)
7850             jp1=iabs(j1)
7851 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7852 !     &         ' jj=',jj,' kk=',kk
7853 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7854             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7855                 .or. j.lt.0 .and. j1.gt.0) .and. &
7856                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7857 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7858 ! The system gains extra energy.
7859               n_corr=n_corr+1
7860               sqd1=dsqrt(d_cont(jj,i))
7861               sqd2=dsqrt(d_cont(kk,i1))
7862               sred_geom = sqd1*sqd2
7863               IF (sred_geom.lt.cutoff_corr) THEN
7864                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7865                   ekont,fprimcont)
7866 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7867 !d     &         ' jj=',jj,' kk=',kk
7868                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7869                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7870                 do l=1,3
7871                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7872                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7873                 enddo
7874                 n_corr1=n_corr1+1
7875 !d               write (iout,*) 'sred_geom=',sred_geom,
7876 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7877 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7878 !d               write (iout,*) "g_contij",g_contij
7879 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7880 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7881                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7882                 if (wcorr4.gt.0.0d0) &
7883                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7884                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7885                        write (iout,'(a6,4i5,0pf7.3)') &
7886                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7887 !                write (iout,*) "gradcorr5 before eello5"
7888 !                do iii=1,nres
7889 !                  write (iout,'(i5,3f10.5)')
7890 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7891 !                enddo
7892                 if (wcorr5.gt.0.0d0) &
7893                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7894 !                write (iout,*) "gradcorr5 after eello5"
7895 !                do iii=1,nres
7896 !                  write (iout,'(i5,3f10.5)')
7897 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7898 !                enddo
7899                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7900                        write (iout,'(a6,4i5,0pf7.3)') &
7901                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7902 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7903 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7904                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7905                      .or. wturn6.eq.0.0d0))then
7906 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7907                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7908                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7909                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7910 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7911 !d     &            'ecorr6=',ecorr6
7912 !d                write (iout,'(4e15.5)') sred_geom,
7913 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7914 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7915 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7916                 else if (wturn6.gt.0.0d0 &
7917                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7918 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7919                   eturn6=eturn6+eello_turn6(i,jj,kk)
7920                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7921                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7922 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7923                 endif
7924               ENDIF
7925 1111          continue
7926             endif
7927           enddo ! kk
7928         enddo ! jj
7929       enddo ! i
7930       do i=1,nres
7931         num_cont_hb(i)=num_cont_hb_old(i)
7932       enddo
7933 !                write (iout,*) "gradcorr5 in eello5"
7934 !                do iii=1,nres
7935 !                  write (iout,'(i5,3f10.5)')
7936 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7937 !                enddo
7938       return
7939       end subroutine multibody_eello
7940 !-----------------------------------------------------------------------------
7941       subroutine add_hb_contact_eello(ii,jj,itask)
7942 !      implicit real*8 (a-h,o-z)
7943 !      include "DIMENSIONS"
7944 !      include "COMMON.IOUNITS"
7945 !      include "COMMON.CONTACTS"
7946 !      integer,parameter :: maxconts=nres/4
7947       integer,parameter :: max_dim=70
7948       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7949 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7950 !      common /przechowalnia/ zapas
7951
7952       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7953       integer,dimension(4) ::itask
7954 !      write (iout,*) "itask",itask
7955       do i=1,2
7956         iproc=itask(i)
7957         if (iproc.gt.0) then
7958           do j=1,num_cont_hb(ii)
7959             jjc=jcont_hb(j,ii)
7960 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7961             if (jjc.eq.jj) then
7962               ncont_sent(iproc)=ncont_sent(iproc)+1
7963               nn=ncont_sent(iproc)
7964               zapas(1,nn,iproc)=ii
7965               zapas(2,nn,iproc)=jjc
7966               zapas(3,nn,iproc)=d_cont(j,ii)
7967               ind=3
7968               do kk=1,3
7969                 ind=ind+1
7970                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7971               enddo
7972               do kk=1,2
7973                 do ll=1,2
7974                   ind=ind+1
7975                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7976                 enddo
7977               enddo
7978               do jj=1,5
7979                 do kk=1,3
7980                   do ll=1,2
7981                     do mm=1,2
7982                       ind=ind+1
7983                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7984                     enddo
7985                   enddo
7986                 enddo
7987               enddo
7988               exit
7989             endif
7990           enddo
7991         endif
7992       enddo
7993       return
7994       end subroutine add_hb_contact_eello
7995 !-----------------------------------------------------------------------------
7996       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7997 !      implicit real*8 (a-h,o-z)
7998 !      include 'DIMENSIONS'
7999 !      include 'COMMON.IOUNITS'
8000 !      include 'COMMON.DERIV'
8001 !      include 'COMMON.INTERACT'
8002 !      include 'COMMON.CONTACTS'
8003       real(kind=8),dimension(3) :: gx,gx1
8004       logical :: lprn
8005 !el local variables
8006       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8007       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8008                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8009                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8010                    rlocshield
8011
8012       lprn=.false.
8013       eij=facont_hb(jj,i)
8014       ekl=facont_hb(kk,k)
8015       ees0pij=ees0p(jj,i)
8016       ees0pkl=ees0p(kk,k)
8017       ees0mij=ees0m(jj,i)
8018       ees0mkl=ees0m(kk,k)
8019       ekont=eij*ekl
8020       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8021 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8022 ! Following 4 lines for diagnostics.
8023 !d    ees0pkl=0.0D0
8024 !d    ees0pij=1.0D0
8025 !d    ees0mkl=0.0D0
8026 !d    ees0mij=1.0D0
8027 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8028 !     & 'Contacts ',i,j,
8029 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8030 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8031 !     & 'gradcorr_long'
8032 ! Calculate the multi-body contribution to energy.
8033 !      ecorr=ecorr+ekont*ees
8034 ! Calculate multi-body contributions to the gradient.
8035       coeffpees0pij=coeffp*ees0pij
8036       coeffmees0mij=coeffm*ees0mij
8037       coeffpees0pkl=coeffp*ees0pkl
8038       coeffmees0mkl=coeffm*ees0mkl
8039       do ll=1,3
8040 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8041         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8042         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8043         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8044         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8045         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8046         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8047 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8048         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8049         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8050         coeffmees0mij*gacontm_hb1(ll,kk,k))
8051         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8052         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8053         coeffmees0mij*gacontm_hb2(ll,kk,k))
8054         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8055            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8056            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8057         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8058         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8059         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8060            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8061            coeffmees0mij*gacontm_hb3(ll,kk,k))
8062         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8063         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8064 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8065       enddo
8066 !      write (iout,*)
8067 !grad      do m=i+1,j-1
8068 !grad        do ll=1,3
8069 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8070 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8071 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8072 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8073 !grad        enddo
8074 !grad      enddo
8075 !grad      do m=k+1,l-1
8076 !grad        do ll=1,3
8077 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8078 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8079 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8080 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8081 !grad        enddo
8082 !grad      enddo
8083 !      write (iout,*) "ehbcorr",ekont*ees
8084       ehbcorr=ekont*ees
8085       if (shield_mode.gt.0) then
8086        j=ees0plist(jj,i)
8087        l=ees0plist(kk,k)
8088 !C        print *,i,j,fac_shield(i),fac_shield(j),
8089 !C     &fac_shield(k),fac_shield(l)
8090         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8091            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8092           do ilist=1,ishield_list(i)
8093            iresshield=shield_list(ilist,i)
8094            do m=1,3
8095            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8096            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8097                    rlocshield  &
8098             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8099             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8100             +rlocshield
8101            enddo
8102           enddo
8103           do ilist=1,ishield_list(j)
8104            iresshield=shield_list(ilist,j)
8105            do m=1,3
8106            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8107            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8108                    rlocshield &
8109             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8110            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8111             +rlocshield
8112            enddo
8113           enddo
8114
8115           do ilist=1,ishield_list(k)
8116            iresshield=shield_list(ilist,k)
8117            do m=1,3
8118            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8119            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8120                    rlocshield &
8121             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8122            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8123             +rlocshield
8124            enddo
8125           enddo
8126           do ilist=1,ishield_list(l)
8127            iresshield=shield_list(ilist,l)
8128            do m=1,3
8129            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8130            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8131                    rlocshield &
8132             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8133            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8134             +rlocshield
8135            enddo
8136           enddo
8137           do m=1,3
8138             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8139                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8140             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8141                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8142             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8143                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8144             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8145                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8146
8147             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8148                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8149             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8150                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8151             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8152                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8153             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8154                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8155
8156            enddo
8157       endif
8158       endif
8159       return
8160       end function ehbcorr
8161 #ifdef MOMENT
8162 !-----------------------------------------------------------------------------
8163       subroutine dipole(i,j,jj)
8164 !      implicit real*8 (a-h,o-z)
8165 !      include 'DIMENSIONS'
8166 !      include 'COMMON.IOUNITS'
8167 !      include 'COMMON.CHAIN'
8168 !      include 'COMMON.FFIELD'
8169 !      include 'COMMON.DERIV'
8170 !      include 'COMMON.INTERACT'
8171 !      include 'COMMON.CONTACTS'
8172 !      include 'COMMON.TORSION'
8173 !      include 'COMMON.VAR'
8174 !      include 'COMMON.GEO'
8175       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8176       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8177       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8178
8179       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8180       allocate(dipderx(3,5,4,maxconts,nres))
8181 !
8182
8183       iti1 = itortyp(itype(i+1,1))
8184       if (j.lt.nres-1) then
8185         itj1 = itortyp(itype(j+1,1))
8186       else
8187         itj1=ntortyp+1
8188       endif
8189       do iii=1,2
8190         dipi(iii,1)=Ub2(iii,i)
8191         dipderi(iii)=Ub2der(iii,i)
8192         dipi(iii,2)=b1(iii,iti1)
8193         dipj(iii,1)=Ub2(iii,j)
8194         dipderj(iii)=Ub2der(iii,j)
8195         dipj(iii,2)=b1(iii,itj1)
8196       enddo
8197       kkk=0
8198       do iii=1,2
8199         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8200         do jjj=1,2
8201           kkk=kkk+1
8202           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8203         enddo
8204       enddo
8205       do kkk=1,5
8206         do lll=1,3
8207           mmm=0
8208           do iii=1,2
8209             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8210               auxvec(1))
8211             do jjj=1,2
8212               mmm=mmm+1
8213               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8214             enddo
8215           enddo
8216         enddo
8217       enddo
8218       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8219       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8220       do iii=1,2
8221         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8222       enddo
8223       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8224       do iii=1,2
8225         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8226       enddo
8227       return
8228       end subroutine dipole
8229 #endif
8230 !-----------------------------------------------------------------------------
8231       subroutine calc_eello(i,j,k,l,jj,kk)
8232 !
8233 ! This subroutine computes matrices and vectors needed to calculate
8234 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8235 !
8236       use comm_kut
8237 !      implicit real*8 (a-h,o-z)
8238 !      include 'DIMENSIONS'
8239 !      include 'COMMON.IOUNITS'
8240 !      include 'COMMON.CHAIN'
8241 !      include 'COMMON.DERIV'
8242 !      include 'COMMON.INTERACT'
8243 !      include 'COMMON.CONTACTS'
8244 !      include 'COMMON.TORSION'
8245 !      include 'COMMON.VAR'
8246 !      include 'COMMON.GEO'
8247 !      include 'COMMON.FFIELD'
8248       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8249       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8250       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8251               itj1
8252 !el      logical :: lprn
8253 !el      common /kutas/ lprn
8254 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8255 !d     & ' jj=',jj,' kk=',kk
8256 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8257 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8258 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8259       do iii=1,2
8260         do jjj=1,2
8261           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8262           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8263         enddo
8264       enddo
8265       call transpose2(aa1(1,1),aa1t(1,1))
8266       call transpose2(aa2(1,1),aa2t(1,1))
8267       do kkk=1,5
8268         do lll=1,3
8269           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8270             aa1tder(1,1,lll,kkk))
8271           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8272             aa2tder(1,1,lll,kkk))
8273         enddo
8274       enddo
8275       if (l.eq.j+1) then
8276 ! parallel orientation of the two CA-CA-CA frames.
8277         if (i.gt.1) then
8278           iti=itortyp(itype(i,1))
8279         else
8280           iti=ntortyp+1
8281         endif
8282         itk1=itortyp(itype(k+1,1))
8283         itj=itortyp(itype(j,1))
8284         if (l.lt.nres-1) then
8285           itl1=itortyp(itype(l+1,1))
8286         else
8287           itl1=ntortyp+1
8288         endif
8289 ! A1 kernel(j+1) A2T
8290 !d        do iii=1,2
8291 !d          write (iout,'(3f10.5,5x,3f10.5)')
8292 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8293 !d        enddo
8294         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8295          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8296          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8297 ! Following matrices are needed only for 6-th order cumulants
8298         IF (wcorr6.gt.0.0d0) THEN
8299         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8300          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8301          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8302         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8303          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8304          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8305          ADtEAderx(1,1,1,1,1,1))
8306         lprn=.false.
8307         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8308          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8309          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8310          ADtEA1derx(1,1,1,1,1,1))
8311         ENDIF
8312 ! End 6-th order cumulants
8313 !d        lprn=.false.
8314 !d        if (lprn) then
8315 !d        write (2,*) 'In calc_eello6'
8316 !d        do iii=1,2
8317 !d          write (2,*) 'iii=',iii
8318 !d          do kkk=1,5
8319 !d            write (2,*) 'kkk=',kkk
8320 !d            do jjj=1,2
8321 !d              write (2,'(3(2f10.5),5x)')
8322 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8323 !d            enddo
8324 !d          enddo
8325 !d        enddo
8326 !d        endif
8327         call transpose2(EUgder(1,1,k),auxmat(1,1))
8328         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8329         call transpose2(EUg(1,1,k),auxmat(1,1))
8330         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8331         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8332         do iii=1,2
8333           do kkk=1,5
8334             do lll=1,3
8335               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8336                 EAEAderx(1,1,lll,kkk,iii,1))
8337             enddo
8338           enddo
8339         enddo
8340 ! A1T kernel(i+1) A2
8341         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8342          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8343          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8344 ! Following matrices are needed only for 6-th order cumulants
8345         IF (wcorr6.gt.0.0d0) THEN
8346         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8347          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8348          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8349         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8350          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8351          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8352          ADtEAderx(1,1,1,1,1,2))
8353         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8354          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8355          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8356          ADtEA1derx(1,1,1,1,1,2))
8357         ENDIF
8358 ! End 6-th order cumulants
8359         call transpose2(EUgder(1,1,l),auxmat(1,1))
8360         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8361         call transpose2(EUg(1,1,l),auxmat(1,1))
8362         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8363         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8364         do iii=1,2
8365           do kkk=1,5
8366             do lll=1,3
8367               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8368                 EAEAderx(1,1,lll,kkk,iii,2))
8369             enddo
8370           enddo
8371         enddo
8372 ! AEAb1 and AEAb2
8373 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8374 ! They are needed only when the fifth- or the sixth-order cumulants are
8375 ! indluded.
8376         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8377         call transpose2(AEA(1,1,1),auxmat(1,1))
8378         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8379         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8380         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8381         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8382         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8383         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8384         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8385         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8386         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8387         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8388         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8389         call transpose2(AEA(1,1,2),auxmat(1,1))
8390         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8391         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8392         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8393         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8394         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8395         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8396         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8397         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8398         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8399         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8400         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8401 ! Calculate the Cartesian derivatives of the vectors.
8402         do iii=1,2
8403           do kkk=1,5
8404             do lll=1,3
8405               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8406               call matvec2(auxmat(1,1),b1(1,iti),&
8407                 AEAb1derx(1,lll,kkk,iii,1,1))
8408               call matvec2(auxmat(1,1),Ub2(1,i),&
8409                 AEAb2derx(1,lll,kkk,iii,1,1))
8410               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8411                 AEAb1derx(1,lll,kkk,iii,2,1))
8412               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8413                 AEAb2derx(1,lll,kkk,iii,2,1))
8414               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8415               call matvec2(auxmat(1,1),b1(1,itj),&
8416                 AEAb1derx(1,lll,kkk,iii,1,2))
8417               call matvec2(auxmat(1,1),Ub2(1,j),&
8418                 AEAb2derx(1,lll,kkk,iii,1,2))
8419               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8420                 AEAb1derx(1,lll,kkk,iii,2,2))
8421               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8422                 AEAb2derx(1,lll,kkk,iii,2,2))
8423             enddo
8424           enddo
8425         enddo
8426         ENDIF
8427 ! End vectors
8428       else
8429 ! Antiparallel orientation of the two CA-CA-CA frames.
8430         if (i.gt.1) then
8431           iti=itortyp(itype(i,1))
8432         else
8433           iti=ntortyp+1
8434         endif
8435         itk1=itortyp(itype(k+1,1))
8436         itl=itortyp(itype(l,1))
8437         itj=itortyp(itype(j,1))
8438         if (j.lt.nres-1) then
8439           itj1=itortyp(itype(j+1,1))
8440         else
8441           itj1=ntortyp+1
8442         endif
8443 ! A2 kernel(j-1)T A1T
8444         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8445          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8446          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8447 ! Following matrices are needed only for 6-th order cumulants
8448         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8449            j.eq.i+4 .and. l.eq.i+3)) THEN
8450         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8451          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8452          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8453         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8454          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8455          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8456          ADtEAderx(1,1,1,1,1,1))
8457         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8458          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8459          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8460          ADtEA1derx(1,1,1,1,1,1))
8461         ENDIF
8462 ! End 6-th order cumulants
8463         call transpose2(EUgder(1,1,k),auxmat(1,1))
8464         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8465         call transpose2(EUg(1,1,k),auxmat(1,1))
8466         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8467         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8468         do iii=1,2
8469           do kkk=1,5
8470             do lll=1,3
8471               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8472                 EAEAderx(1,1,lll,kkk,iii,1))
8473             enddo
8474           enddo
8475         enddo
8476 ! A2T kernel(i+1)T A1
8477         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8478          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8479          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8480 ! Following matrices are needed only for 6-th order cumulants
8481         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8482            j.eq.i+4 .and. l.eq.i+3)) THEN
8483         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8484          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8485          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8486         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8487          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8488          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8489          ADtEAderx(1,1,1,1,1,2))
8490         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8491          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8492          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8493          ADtEA1derx(1,1,1,1,1,2))
8494         ENDIF
8495 ! End 6-th order cumulants
8496         call transpose2(EUgder(1,1,j),auxmat(1,1))
8497         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8498         call transpose2(EUg(1,1,j),auxmat(1,1))
8499         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8500         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8501         do iii=1,2
8502           do kkk=1,5
8503             do lll=1,3
8504               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8505                 EAEAderx(1,1,lll,kkk,iii,2))
8506             enddo
8507           enddo
8508         enddo
8509 ! AEAb1 and AEAb2
8510 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8511 ! They are needed only when the fifth- or the sixth-order cumulants are
8512 ! indluded.
8513         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8514           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8515         call transpose2(AEA(1,1,1),auxmat(1,1))
8516         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8517         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8518         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8519         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8520         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8521         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8522         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8523         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8524         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8525         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8526         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8527         call transpose2(AEA(1,1,2),auxmat(1,1))
8528         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8529         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8530         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8531         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8532         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8533         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8534         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8535         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8536         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8537         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8538         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8539 ! Calculate the Cartesian derivatives of the vectors.
8540         do iii=1,2
8541           do kkk=1,5
8542             do lll=1,3
8543               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8544               call matvec2(auxmat(1,1),b1(1,iti),&
8545                 AEAb1derx(1,lll,kkk,iii,1,1))
8546               call matvec2(auxmat(1,1),Ub2(1,i),&
8547                 AEAb2derx(1,lll,kkk,iii,1,1))
8548               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8549                 AEAb1derx(1,lll,kkk,iii,2,1))
8550               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8551                 AEAb2derx(1,lll,kkk,iii,2,1))
8552               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8553               call matvec2(auxmat(1,1),b1(1,itl),&
8554                 AEAb1derx(1,lll,kkk,iii,1,2))
8555               call matvec2(auxmat(1,1),Ub2(1,l),&
8556                 AEAb2derx(1,lll,kkk,iii,1,2))
8557               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8558                 AEAb1derx(1,lll,kkk,iii,2,2))
8559               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8560                 AEAb2derx(1,lll,kkk,iii,2,2))
8561             enddo
8562           enddo
8563         enddo
8564         ENDIF
8565 ! End vectors
8566       endif
8567       return
8568       end subroutine calc_eello
8569 !-----------------------------------------------------------------------------
8570       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8571       use comm_kut
8572       implicit none
8573       integer :: nderg
8574       logical :: transp
8575       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8576       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8577       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8578       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8579       integer :: iii,kkk,lll
8580       integer :: jjj,mmm
8581 !el      logical :: lprn
8582 !el      common /kutas/ lprn
8583       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8584       do iii=1,nderg
8585         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8586           AKAderg(1,1,iii))
8587       enddo
8588 !d      if (lprn) write (2,*) 'In kernel'
8589       do kkk=1,5
8590 !d        if (lprn) write (2,*) 'kkk=',kkk
8591         do lll=1,3
8592           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8593             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8594 !d          if (lprn) then
8595 !d            write (2,*) 'lll=',lll
8596 !d            write (2,*) 'iii=1'
8597 !d            do jjj=1,2
8598 !d              write (2,'(3(2f10.5),5x)')
8599 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8600 !d            enddo
8601 !d          endif
8602           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8603             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8604 !d          if (lprn) then
8605 !d            write (2,*) 'lll=',lll
8606 !d            write (2,*) 'iii=2'
8607 !d            do jjj=1,2
8608 !d              write (2,'(3(2f10.5),5x)')
8609 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8610 !d            enddo
8611 !d          endif
8612         enddo
8613       enddo
8614       return
8615       end subroutine kernel
8616 !-----------------------------------------------------------------------------
8617       real(kind=8) function eello4(i,j,k,l,jj,kk)
8618 !      implicit real*8 (a-h,o-z)
8619 !      include 'DIMENSIONS'
8620 !      include 'COMMON.IOUNITS'
8621 !      include 'COMMON.CHAIN'
8622 !      include 'COMMON.DERIV'
8623 !      include 'COMMON.INTERACT'
8624 !      include 'COMMON.CONTACTS'
8625 !      include 'COMMON.TORSION'
8626 !      include 'COMMON.VAR'
8627 !      include 'COMMON.GEO'
8628       real(kind=8),dimension(2,2) :: pizda
8629       real(kind=8),dimension(3) :: ggg1,ggg2
8630       real(kind=8) ::  eel4,glongij,glongkl
8631       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8632 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8633 !d        eello4=0.0d0
8634 !d        return
8635 !d      endif
8636 !d      print *,'eello4:',i,j,k,l,jj,kk
8637 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8638 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8639 !old      eij=facont_hb(jj,i)
8640 !old      ekl=facont_hb(kk,k)
8641 !old      ekont=eij*ekl
8642       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8643 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8644       gcorr_loc(k-1)=gcorr_loc(k-1) &
8645          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8646       if (l.eq.j+1) then
8647         gcorr_loc(l-1)=gcorr_loc(l-1) &
8648            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8649       else
8650         gcorr_loc(j-1)=gcorr_loc(j-1) &
8651            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8652       endif
8653       do iii=1,2
8654         do kkk=1,5
8655           do lll=1,3
8656             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8657                               -EAEAderx(2,2,lll,kkk,iii,1)
8658 !d            derx(lll,kkk,iii)=0.0d0
8659           enddo
8660         enddo
8661       enddo
8662 !d      gcorr_loc(l-1)=0.0d0
8663 !d      gcorr_loc(j-1)=0.0d0
8664 !d      gcorr_loc(k-1)=0.0d0
8665 !d      eel4=1.0d0
8666 !d      write (iout,*)'Contacts have occurred for peptide groups',
8667 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8668 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8669       if (j.lt.nres-1) then
8670         j1=j+1
8671         j2=j-1
8672       else
8673         j1=j-1
8674         j2=j-2
8675       endif
8676       if (l.lt.nres-1) then
8677         l1=l+1
8678         l2=l-1
8679       else
8680         l1=l-1
8681         l2=l-2
8682       endif
8683       do ll=1,3
8684 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8685 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8686         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8687         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8688 !grad        ghalf=0.5d0*ggg1(ll)
8689         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8690         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8691         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8692         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8693         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8694         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8695 !grad        ghalf=0.5d0*ggg2(ll)
8696         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8697         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8698         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8699         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8700         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8701         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8702       enddo
8703 !grad      do m=i+1,j-1
8704 !grad        do ll=1,3
8705 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8706 !grad        enddo
8707 !grad      enddo
8708 !grad      do m=k+1,l-1
8709 !grad        do ll=1,3
8710 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8711 !grad        enddo
8712 !grad      enddo
8713 !grad      do m=i+2,j2
8714 !grad        do ll=1,3
8715 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8716 !grad        enddo
8717 !grad      enddo
8718 !grad      do m=k+2,l2
8719 !grad        do ll=1,3
8720 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8721 !grad        enddo
8722 !grad      enddo
8723 !d      do iii=1,nres-3
8724 !d        write (2,*) iii,gcorr_loc(iii)
8725 !d      enddo
8726       eello4=ekont*eel4
8727 !d      write (2,*) 'ekont',ekont
8728 !d      write (iout,*) 'eello4',ekont*eel4
8729       return
8730       end function eello4
8731 !-----------------------------------------------------------------------------
8732       real(kind=8) function eello5(i,j,k,l,jj,kk)
8733 !      implicit real*8 (a-h,o-z)
8734 !      include 'DIMENSIONS'
8735 !      include 'COMMON.IOUNITS'
8736 !      include 'COMMON.CHAIN'
8737 !      include 'COMMON.DERIV'
8738 !      include 'COMMON.INTERACT'
8739 !      include 'COMMON.CONTACTS'
8740 !      include 'COMMON.TORSION'
8741 !      include 'COMMON.VAR'
8742 !      include 'COMMON.GEO'
8743       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8744       real(kind=8),dimension(2) :: vv
8745       real(kind=8),dimension(3) :: ggg1,ggg2
8746       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8747       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8748       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8749 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8750 !                                                                              C
8751 !                            Parallel chains                                   C
8752 !                                                                              C
8753 !          o             o                   o             o                   C
8754 !         /l\           / \             \   / \           / \   /              C
8755 !        /   \         /   \             \ /   \         /   \ /               C
8756 !       j| o |l1       | o |                o| o |         | o |o                C
8757 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8758 !      \i/   \         /   \ /             /   \         /   \                 C
8759 !       o    k1             o                                                  C
8760 !         (I)          (II)                (III)          (IV)                 C
8761 !                                                                              C
8762 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8763 !                                                                              C
8764 !                            Antiparallel chains                               C
8765 !                                                                              C
8766 !          o             o                   o             o                   C
8767 !         /j\           / \             \   / \           / \   /              C
8768 !        /   \         /   \             \ /   \         /   \ /               C
8769 !      j1| o |l        | o |                o| o |         | o |o                C
8770 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8771 !      \i/   \         /   \ /             /   \         /   \                 C
8772 !       o     k1            o                                                  C
8773 !         (I)          (II)                (III)          (IV)                 C
8774 !                                                                              C
8775 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8776 !                                                                              C
8777 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8778 !                                                                              C
8779 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8780 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8781 !d        eello5=0.0d0
8782 !d        return
8783 !d      endif
8784 !d      write (iout,*)
8785 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8786 !d     &   ' and',k,l
8787       itk=itortyp(itype(k,1))
8788       itl=itortyp(itype(l,1))
8789       itj=itortyp(itype(j,1))
8790       eello5_1=0.0d0
8791       eello5_2=0.0d0
8792       eello5_3=0.0d0
8793       eello5_4=0.0d0
8794 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8795 !d     &   eel5_3_num,eel5_4_num)
8796       do iii=1,2
8797         do kkk=1,5
8798           do lll=1,3
8799             derx(lll,kkk,iii)=0.0d0
8800           enddo
8801         enddo
8802       enddo
8803 !d      eij=facont_hb(jj,i)
8804 !d      ekl=facont_hb(kk,k)
8805 !d      ekont=eij*ekl
8806 !d      write (iout,*)'Contacts have occurred for peptide groups',
8807 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8808 !d      goto 1111
8809 ! Contribution from the graph I.
8810 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8811 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8812       call transpose2(EUg(1,1,k),auxmat(1,1))
8813       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8814       vv(1)=pizda(1,1)-pizda(2,2)
8815       vv(2)=pizda(1,2)+pizda(2,1)
8816       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8817        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8818 ! Explicit gradient in virtual-dihedral angles.
8819       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8820        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8821        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8822       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8823       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8824       vv(1)=pizda(1,1)-pizda(2,2)
8825       vv(2)=pizda(1,2)+pizda(2,1)
8826       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8827        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8828        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8829       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8830       vv(1)=pizda(1,1)-pizda(2,2)
8831       vv(2)=pizda(1,2)+pizda(2,1)
8832       if (l.eq.j+1) then
8833         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8834          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8835          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8836       else
8837         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8838          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8839          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8840       endif
8841 ! Cartesian gradient
8842       do iii=1,2
8843         do kkk=1,5
8844           do lll=1,3
8845             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8846               pizda(1,1))
8847             vv(1)=pizda(1,1)-pizda(2,2)
8848             vv(2)=pizda(1,2)+pizda(2,1)
8849             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8850              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8851              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8852           enddo
8853         enddo
8854       enddo
8855 !      goto 1112
8856 !1111  continue
8857 ! Contribution from graph II
8858       call transpose2(EE(1,1,itk),auxmat(1,1))
8859       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8860       vv(1)=pizda(1,1)+pizda(2,2)
8861       vv(2)=pizda(2,1)-pizda(1,2)
8862       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8863        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8864 ! Explicit gradient in virtual-dihedral angles.
8865       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8866        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8867       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8868       vv(1)=pizda(1,1)+pizda(2,2)
8869       vv(2)=pizda(2,1)-pizda(1,2)
8870       if (l.eq.j+1) then
8871         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8872          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8873          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8874       else
8875         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8876          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8877          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8878       endif
8879 ! Cartesian gradient
8880       do iii=1,2
8881         do kkk=1,5
8882           do lll=1,3
8883             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8884               pizda(1,1))
8885             vv(1)=pizda(1,1)+pizda(2,2)
8886             vv(2)=pizda(2,1)-pizda(1,2)
8887             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8888              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8889              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8890           enddo
8891         enddo
8892       enddo
8893 !d      goto 1112
8894 !d1111  continue
8895       if (l.eq.j+1) then
8896 !d        goto 1110
8897 ! Parallel orientation
8898 ! Contribution from graph III
8899         call transpose2(EUg(1,1,l),auxmat(1,1))
8900         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8901         vv(1)=pizda(1,1)-pizda(2,2)
8902         vv(2)=pizda(1,2)+pizda(2,1)
8903         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8904          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8905 ! Explicit gradient in virtual-dihedral angles.
8906         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8907          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8908          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8909         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8910         vv(1)=pizda(1,1)-pizda(2,2)
8911         vv(2)=pizda(1,2)+pizda(2,1)
8912         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8913          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8914          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8915         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8916         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8917         vv(1)=pizda(1,1)-pizda(2,2)
8918         vv(2)=pizda(1,2)+pizda(2,1)
8919         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8920          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8921          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8922 ! Cartesian gradient
8923         do iii=1,2
8924           do kkk=1,5
8925             do lll=1,3
8926               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8927                 pizda(1,1))
8928               vv(1)=pizda(1,1)-pizda(2,2)
8929               vv(2)=pizda(1,2)+pizda(2,1)
8930               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8931                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8932                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8933             enddo
8934           enddo
8935         enddo
8936 !d        goto 1112
8937 ! Contribution from graph IV
8938 !d1110    continue
8939         call transpose2(EE(1,1,itl),auxmat(1,1))
8940         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8941         vv(1)=pizda(1,1)+pizda(2,2)
8942         vv(2)=pizda(2,1)-pizda(1,2)
8943         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8944          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8945 ! Explicit gradient in virtual-dihedral angles.
8946         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8947          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8948         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8949         vv(1)=pizda(1,1)+pizda(2,2)
8950         vv(2)=pizda(2,1)-pizda(1,2)
8951         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8952          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8953          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8954 ! Cartesian gradient
8955         do iii=1,2
8956           do kkk=1,5
8957             do lll=1,3
8958               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8959                 pizda(1,1))
8960               vv(1)=pizda(1,1)+pizda(2,2)
8961               vv(2)=pizda(2,1)-pizda(1,2)
8962               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8963                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8964                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8965             enddo
8966           enddo
8967         enddo
8968       else
8969 ! Antiparallel orientation
8970 ! Contribution from graph III
8971 !        goto 1110
8972         call transpose2(EUg(1,1,j),auxmat(1,1))
8973         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8974         vv(1)=pizda(1,1)-pizda(2,2)
8975         vv(2)=pizda(1,2)+pizda(2,1)
8976         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8977          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8978 ! Explicit gradient in virtual-dihedral angles.
8979         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8980          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8981          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8982         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8983         vv(1)=pizda(1,1)-pizda(2,2)
8984         vv(2)=pizda(1,2)+pizda(2,1)
8985         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8986          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8987          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8988         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8989         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8990         vv(1)=pizda(1,1)-pizda(2,2)
8991         vv(2)=pizda(1,2)+pizda(2,1)
8992         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8993          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8994          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8995 ! Cartesian gradient
8996         do iii=1,2
8997           do kkk=1,5
8998             do lll=1,3
8999               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9000                 pizda(1,1))
9001               vv(1)=pizda(1,1)-pizda(2,2)
9002               vv(2)=pizda(1,2)+pizda(2,1)
9003               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9004                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9005                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9006             enddo
9007           enddo
9008         enddo
9009 !d        goto 1112
9010 ! Contribution from graph IV
9011 1110    continue
9012         call transpose2(EE(1,1,itj),auxmat(1,1))
9013         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9014         vv(1)=pizda(1,1)+pizda(2,2)
9015         vv(2)=pizda(2,1)-pizda(1,2)
9016         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9017          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9018 ! Explicit gradient in virtual-dihedral angles.
9019         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9020          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9021         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9022         vv(1)=pizda(1,1)+pizda(2,2)
9023         vv(2)=pizda(2,1)-pizda(1,2)
9024         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9025          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9026          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9027 ! Cartesian gradient
9028         do iii=1,2
9029           do kkk=1,5
9030             do lll=1,3
9031               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9032                 pizda(1,1))
9033               vv(1)=pizda(1,1)+pizda(2,2)
9034               vv(2)=pizda(2,1)-pizda(1,2)
9035               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9036                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9037                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9038             enddo
9039           enddo
9040         enddo
9041       endif
9042 1112  continue
9043       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9044 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9045 !d        write (2,*) 'ijkl',i,j,k,l
9046 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9047 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9048 !d      endif
9049 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9050 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9051 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9052 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9053       if (j.lt.nres-1) then
9054         j1=j+1
9055         j2=j-1
9056       else
9057         j1=j-1
9058         j2=j-2
9059       endif
9060       if (l.lt.nres-1) then
9061         l1=l+1
9062         l2=l-1
9063       else
9064         l1=l-1
9065         l2=l-2
9066       endif
9067 !d      eij=1.0d0
9068 !d      ekl=1.0d0
9069 !d      ekont=1.0d0
9070 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9071 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9072 !        summed up outside the subrouine as for the other subroutines
9073 !        handling long-range interactions. The old code is commented out
9074 !        with "cgrad" to keep track of changes.
9075       do ll=1,3
9076 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9077 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9078         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9079         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9080 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9081 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9082 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9083 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9084 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9085 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9086 !     &   gradcorr5ij,
9087 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9088 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9089 !grad        ghalf=0.5d0*ggg1(ll)
9090 !d        ghalf=0.0d0
9091         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9092         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9093         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9094         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9095         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9096         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9097 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9098 !grad        ghalf=0.5d0*ggg2(ll)
9099         ghalf=0.0d0
9100         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9101         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9102         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9103         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9104         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9105         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9106       enddo
9107 !d      goto 1112
9108 !grad      do m=i+1,j-1
9109 !grad        do ll=1,3
9110 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9111 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9112 !grad        enddo
9113 !grad      enddo
9114 !grad      do m=k+1,l-1
9115 !grad        do ll=1,3
9116 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9117 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9118 !grad        enddo
9119 !grad      enddo
9120 !1112  continue
9121 !grad      do m=i+2,j2
9122 !grad        do ll=1,3
9123 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9124 !grad        enddo
9125 !grad      enddo
9126 !grad      do m=k+2,l2
9127 !grad        do ll=1,3
9128 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9129 !grad        enddo
9130 !grad      enddo
9131 !d      do iii=1,nres-3
9132 !d        write (2,*) iii,g_corr5_loc(iii)
9133 !d      enddo
9134       eello5=ekont*eel5
9135 !d      write (2,*) 'ekont',ekont
9136 !d      write (iout,*) 'eello5',ekont*eel5
9137       return
9138       end function eello5
9139 !-----------------------------------------------------------------------------
9140       real(kind=8) function eello6(i,j,k,l,jj,kk)
9141 !      implicit real*8 (a-h,o-z)
9142 !      include 'DIMENSIONS'
9143 !      include 'COMMON.IOUNITS'
9144 !      include 'COMMON.CHAIN'
9145 !      include 'COMMON.DERIV'
9146 !      include 'COMMON.INTERACT'
9147 !      include 'COMMON.CONTACTS'
9148 !      include 'COMMON.TORSION'
9149 !      include 'COMMON.VAR'
9150 !      include 'COMMON.GEO'
9151 !      include 'COMMON.FFIELD'
9152       real(kind=8),dimension(3) :: ggg1,ggg2
9153       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9154                    eello6_6,eel6
9155       real(kind=8) :: gradcorr6ij,gradcorr6kl
9156       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9157 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9158 !d        eello6=0.0d0
9159 !d        return
9160 !d      endif
9161 !d      write (iout,*)
9162 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9163 !d     &   ' and',k,l
9164       eello6_1=0.0d0
9165       eello6_2=0.0d0
9166       eello6_3=0.0d0
9167       eello6_4=0.0d0
9168       eello6_5=0.0d0
9169       eello6_6=0.0d0
9170 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9171 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9172       do iii=1,2
9173         do kkk=1,5
9174           do lll=1,3
9175             derx(lll,kkk,iii)=0.0d0
9176           enddo
9177         enddo
9178       enddo
9179 !d      eij=facont_hb(jj,i)
9180 !d      ekl=facont_hb(kk,k)
9181 !d      ekont=eij*ekl
9182 !d      eij=1.0d0
9183 !d      ekl=1.0d0
9184 !d      ekont=1.0d0
9185       if (l.eq.j+1) then
9186         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9187         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9188         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9189         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9190         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9191         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9192       else
9193         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9194         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9195         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9196         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9197         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9198           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9199         else
9200           eello6_5=0.0d0
9201         endif
9202         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9203       endif
9204 ! If turn contributions are considered, they will be handled separately.
9205       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9206 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9207 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9208 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9209 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9210 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9211 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9212 !d      goto 1112
9213       if (j.lt.nres-1) then
9214         j1=j+1
9215         j2=j-1
9216       else
9217         j1=j-1
9218         j2=j-2
9219       endif
9220       if (l.lt.nres-1) then
9221         l1=l+1
9222         l2=l-1
9223       else
9224         l1=l-1
9225         l2=l-2
9226       endif
9227       do ll=1,3
9228 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9229 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9230 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9231 !grad        ghalf=0.5d0*ggg1(ll)
9232 !d        ghalf=0.0d0
9233         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9234         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9235         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9236         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9237         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9238         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9239         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9240         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9241 !grad        ghalf=0.5d0*ggg2(ll)
9242 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9243 !d        ghalf=0.0d0
9244         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9245         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9246         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9247         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9248         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9249         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9250       enddo
9251 !d      goto 1112
9252 !grad      do m=i+1,j-1
9253 !grad        do ll=1,3
9254 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9255 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9256 !grad        enddo
9257 !grad      enddo
9258 !grad      do m=k+1,l-1
9259 !grad        do ll=1,3
9260 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9261 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9262 !grad        enddo
9263 !grad      enddo
9264 !grad1112  continue
9265 !grad      do m=i+2,j2
9266 !grad        do ll=1,3
9267 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9268 !grad        enddo
9269 !grad      enddo
9270 !grad      do m=k+2,l2
9271 !grad        do ll=1,3
9272 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9273 !grad        enddo
9274 !grad      enddo
9275 !d      do iii=1,nres-3
9276 !d        write (2,*) iii,g_corr6_loc(iii)
9277 !d      enddo
9278       eello6=ekont*eel6
9279 !d      write (2,*) 'ekont',ekont
9280 !d      write (iout,*) 'eello6',ekont*eel6
9281       return
9282       end function eello6
9283 !-----------------------------------------------------------------------------
9284       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9285       use comm_kut
9286 !      implicit real*8 (a-h,o-z)
9287 !      include 'DIMENSIONS'
9288 !      include 'COMMON.IOUNITS'
9289 !      include 'COMMON.CHAIN'
9290 !      include 'COMMON.DERIV'
9291 !      include 'COMMON.INTERACT'
9292 !      include 'COMMON.CONTACTS'
9293 !      include 'COMMON.TORSION'
9294 !      include 'COMMON.VAR'
9295 !      include 'COMMON.GEO'
9296       real(kind=8),dimension(2) :: vv,vv1
9297       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9298       logical :: swap
9299 !el      logical :: lprn
9300 !el      common /kutas/ lprn
9301       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9302       real(kind=8) :: s1,s2,s3,s4,s5
9303 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9304 !                                                                              C
9305 !      Parallel       Antiparallel                                             C
9306 !                                                                              C
9307 !          o             o                                                     C
9308 !         /l\           /j\                                                    C
9309 !        /   \         /   \                                                   C
9310 !       /| o |         | o |\                                                  C
9311 !     \ j|/k\|  /   \  |/k\|l /                                                C
9312 !      \ /   \ /     \ /   \ /                                                 C
9313 !       o     o       o     o                                                  C
9314 !       i             i                                                        C
9315 !                                                                              C
9316 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9317       itk=itortyp(itype(k,1))
9318       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9319       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9320       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9321       call transpose2(EUgC(1,1,k),auxmat(1,1))
9322       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9323       vv1(1)=pizda1(1,1)-pizda1(2,2)
9324       vv1(2)=pizda1(1,2)+pizda1(2,1)
9325       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9326       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9327       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9328       s5=scalar2(vv(1),Dtobr2(1,i))
9329 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9330       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9331       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9332        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9333        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9334        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9335        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9336        +scalar2(vv(1),Dtobr2der(1,i)))
9337       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9338       vv1(1)=pizda1(1,1)-pizda1(2,2)
9339       vv1(2)=pizda1(1,2)+pizda1(2,1)
9340       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9341       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9342       if (l.eq.j+1) then
9343         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9344        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9345        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9346        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9347        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9348       else
9349         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9350        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9351        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9352        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9353        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9354       endif
9355       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9356       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9357       vv1(1)=pizda1(1,1)-pizda1(2,2)
9358       vv1(2)=pizda1(1,2)+pizda1(2,1)
9359       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9360        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9361        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9362        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9363       do iii=1,2
9364         if (swap) then
9365           ind=3-iii
9366         else
9367           ind=iii
9368         endif
9369         do kkk=1,5
9370           do lll=1,3
9371             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9372             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9373             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9374             call transpose2(EUgC(1,1,k),auxmat(1,1))
9375             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9376               pizda1(1,1))
9377             vv1(1)=pizda1(1,1)-pizda1(2,2)
9378             vv1(2)=pizda1(1,2)+pizda1(2,1)
9379             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9380             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9381              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9382             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9383              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9384             s5=scalar2(vv(1),Dtobr2(1,i))
9385             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9386           enddo
9387         enddo
9388       enddo
9389       return
9390       end function eello6_graph1
9391 !-----------------------------------------------------------------------------
9392       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9393       use comm_kut
9394 !      implicit real*8 (a-h,o-z)
9395 !      include 'DIMENSIONS'
9396 !      include 'COMMON.IOUNITS'
9397 !      include 'COMMON.CHAIN'
9398 !      include 'COMMON.DERIV'
9399 !      include 'COMMON.INTERACT'
9400 !      include 'COMMON.CONTACTS'
9401 !      include 'COMMON.TORSION'
9402 !      include 'COMMON.VAR'
9403 !      include 'COMMON.GEO'
9404       logical :: swap
9405       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9406       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9407 !el      logical :: lprn
9408 !el      common /kutas/ lprn
9409       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9410       real(kind=8) :: s2,s3,s4
9411 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9412 !                                                                              C
9413 !      Parallel       Antiparallel                                             C
9414 !                                                                              C
9415 !          o             o                                                     C
9416 !     \   /l\           /j\   /                                                C
9417 !      \ /   \         /   \ /                                                 C
9418 !       o| o |         | o |o                                                  C
9419 !     \ j|/k\|      \  |/k\|l                                                  C
9420 !      \ /   \       \ /   \                                                   C
9421 !       o             o                                                        C
9422 !       i             i                                                        C
9423 !                                                                              C
9424 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9425 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9426 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9427 !           but not in a cluster cumulant
9428 #ifdef MOMENT
9429       s1=dip(1,jj,i)*dip(1,kk,k)
9430 #endif
9431       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9432       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9433       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9434       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9435       call transpose2(EUg(1,1,k),auxmat(1,1))
9436       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9437       vv(1)=pizda(1,1)-pizda(2,2)
9438       vv(2)=pizda(1,2)+pizda(2,1)
9439       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9440 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9441 #ifdef MOMENT
9442       eello6_graph2=-(s1+s2+s3+s4)
9443 #else
9444       eello6_graph2=-(s2+s3+s4)
9445 #endif
9446 !      eello6_graph2=-s3
9447 ! Derivatives in gamma(i-1)
9448       if (i.gt.1) then
9449 #ifdef MOMENT
9450         s1=dipderg(1,jj,i)*dip(1,kk,k)
9451 #endif
9452         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9453         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9454         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9455         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9456 #ifdef MOMENT
9457         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9458 #else
9459         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9460 #endif
9461 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9462       endif
9463 ! Derivatives in gamma(k-1)
9464 #ifdef MOMENT
9465       s1=dip(1,jj,i)*dipderg(1,kk,k)
9466 #endif
9467       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9468       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9469       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9470       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9471       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9472       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9473       vv(1)=pizda(1,1)-pizda(2,2)
9474       vv(2)=pizda(1,2)+pizda(2,1)
9475       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9476 #ifdef MOMENT
9477       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9478 #else
9479       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9480 #endif
9481 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9482 ! Derivatives in gamma(j-1) or gamma(l-1)
9483       if (j.gt.1) then
9484 #ifdef MOMENT
9485         s1=dipderg(3,jj,i)*dip(1,kk,k)
9486 #endif
9487         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9488         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9489         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9490         call matmat2(ADtEA1derg(1,1,1,1),auxmat(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         if (swap) then
9496           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9497         else
9498           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9499         endif
9500 #endif
9501         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9502 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9503       endif
9504 ! Derivatives in gamma(l-1) or gamma(j-1)
9505       if (l.gt.1) then
9506 #ifdef MOMENT
9507         s1=dip(1,jj,i)*dipderg(3,kk,k)
9508 #endif
9509         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9510         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9511         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9512         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9513         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9514         vv(1)=pizda(1,1)-pizda(2,2)
9515         vv(2)=pizda(1,2)+pizda(2,1)
9516         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9517 #ifdef MOMENT
9518         if (swap) then
9519           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9520         else
9521           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9522         endif
9523 #endif
9524         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9525 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9526       endif
9527 ! Cartesian derivatives.
9528       if (lprn) then
9529         write (2,*) 'In eello6_graph2'
9530         do iii=1,2
9531           write (2,*) 'iii=',iii
9532           do kkk=1,5
9533             write (2,*) 'kkk=',kkk
9534             do jjj=1,2
9535               write (2,'(3(2f10.5),5x)') &
9536               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9537             enddo
9538           enddo
9539         enddo
9540       endif
9541       do iii=1,2
9542         do kkk=1,5
9543           do lll=1,3
9544 #ifdef MOMENT
9545             if (iii.eq.1) then
9546               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9547             else
9548               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9549             endif
9550 #endif
9551             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9552               auxvec(1))
9553             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9554             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9555               auxvec(1))
9556             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9557             call transpose2(EUg(1,1,k),auxmat(1,1))
9558             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9559               pizda(1,1))
9560             vv(1)=pizda(1,1)-pizda(2,2)
9561             vv(2)=pizda(1,2)+pizda(2,1)
9562             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9563 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9564 #ifdef MOMENT
9565             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9566 #else
9567             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9568 #endif
9569             if (swap) then
9570               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9571             else
9572               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9573             endif
9574           enddo
9575         enddo
9576       enddo
9577       return
9578       end function eello6_graph2
9579 !-----------------------------------------------------------------------------
9580       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9581 !      implicit real*8 (a-h,o-z)
9582 !      include 'DIMENSIONS'
9583 !      include 'COMMON.IOUNITS'
9584 !      include 'COMMON.CHAIN'
9585 !      include 'COMMON.DERIV'
9586 !      include 'COMMON.INTERACT'
9587 !      include 'COMMON.CONTACTS'
9588 !      include 'COMMON.TORSION'
9589 !      include 'COMMON.VAR'
9590 !      include 'COMMON.GEO'
9591       real(kind=8),dimension(2) :: vv,auxvec
9592       real(kind=8),dimension(2,2) :: pizda,auxmat
9593       logical :: swap
9594       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9595       real(kind=8) :: s1,s2,s3,s4
9596 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9597 !                                                                              C
9598 !      Parallel       Antiparallel                                             C
9599 !                                                                              C
9600 !          o             o                                                     C
9601 !         /l\   /   \   /j\                                                    C
9602 !        /   \ /     \ /   \                                                   C
9603 !       /| o |o       o| o |\                                                  C
9604 !       j|/k\|  /      |/k\|l /                                                C
9605 !        /   \ /       /   \ /                                                 C
9606 !       /     o       /     o                                                  C
9607 !       i             i                                                        C
9608 !                                                                              C
9609 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9610 !
9611 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9612 !           energy moment and not to the cluster cumulant.
9613       iti=itortyp(itype(i,1))
9614       if (j.lt.nres-1) then
9615         itj1=itortyp(itype(j+1,1))
9616       else
9617         itj1=ntortyp+1
9618       endif
9619       itk=itortyp(itype(k,1))
9620       itk1=itortyp(itype(k+1,1))
9621       if (l.lt.nres-1) then
9622         itl1=itortyp(itype(l+1,1))
9623       else
9624         itl1=ntortyp+1
9625       endif
9626 #ifdef MOMENT
9627       s1=dip(4,jj,i)*dip(4,kk,k)
9628 #endif
9629       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9630       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9631       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9632       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9633       call transpose2(EE(1,1,itk),auxmat(1,1))
9634       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9635       vv(1)=pizda(1,1)+pizda(2,2)
9636       vv(2)=pizda(2,1)-pizda(1,2)
9637       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9638 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9639 !d     & "sum",-(s2+s3+s4)
9640 #ifdef MOMENT
9641       eello6_graph3=-(s1+s2+s3+s4)
9642 #else
9643       eello6_graph3=-(s2+s3+s4)
9644 #endif
9645 !      eello6_graph3=-s4
9646 ! Derivatives in gamma(k-1)
9647       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9648       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9649       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9650       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9651 ! Derivatives in gamma(l-1)
9652       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9653       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9654       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9655       vv(1)=pizda(1,1)+pizda(2,2)
9656       vv(2)=pizda(2,1)-pizda(1,2)
9657       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9658       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9659 ! Cartesian derivatives.
9660       do iii=1,2
9661         do kkk=1,5
9662           do lll=1,3
9663 #ifdef MOMENT
9664             if (iii.eq.1) then
9665               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9666             else
9667               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9668             endif
9669 #endif
9670             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9671               auxvec(1))
9672             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9673             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9674               auxvec(1))
9675             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9676             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9677               pizda(1,1))
9678             vv(1)=pizda(1,1)+pizda(2,2)
9679             vv(2)=pizda(2,1)-pizda(1,2)
9680             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9681 #ifdef MOMENT
9682             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9683 #else
9684             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9685 #endif
9686             if (swap) then
9687               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9688             else
9689               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9690             endif
9691 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9692           enddo
9693         enddo
9694       enddo
9695       return
9696       end function eello6_graph3
9697 !-----------------------------------------------------------------------------
9698       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9699 !      implicit real*8 (a-h,o-z)
9700 !      include 'DIMENSIONS'
9701 !      include 'COMMON.IOUNITS'
9702 !      include 'COMMON.CHAIN'
9703 !      include 'COMMON.DERIV'
9704 !      include 'COMMON.INTERACT'
9705 !      include 'COMMON.CONTACTS'
9706 !      include 'COMMON.TORSION'
9707 !      include 'COMMON.VAR'
9708 !      include 'COMMON.GEO'
9709 !      include 'COMMON.FFIELD'
9710       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9711       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9712       logical :: swap
9713       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9714               iii,kkk,lll
9715       real(kind=8) :: s1,s2,s3,s4
9716 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9717 !                                                                              C
9718 !      Parallel       Antiparallel                                             C
9719 !                                                                              C
9720 !          o             o                                                     C
9721 !         /l\   /   \   /j\                                                    C
9722 !        /   \ /     \ /   \                                                   C
9723 !       /| o |o       o| o |\                                                  C
9724 !     \ j|/k\|      \  |/k\|l                                                  C
9725 !      \ /   \       \ /   \                                                   C
9726 !       o     \       o     \                                                  C
9727 !       i             i                                                        C
9728 !                                                                              C
9729 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9730 !
9731 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9732 !           energy moment and not to the cluster cumulant.
9733 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9734       iti=itortyp(itype(i,1))
9735       itj=itortyp(itype(j,1))
9736       if (j.lt.nres-1) then
9737         itj1=itortyp(itype(j+1,1))
9738       else
9739         itj1=ntortyp+1
9740       endif
9741       itk=itortyp(itype(k,1))
9742       if (k.lt.nres-1) then
9743         itk1=itortyp(itype(k+1,1))
9744       else
9745         itk1=ntortyp+1
9746       endif
9747       itl=itortyp(itype(l,1))
9748       if (l.lt.nres-1) then
9749         itl1=itortyp(itype(l+1,1))
9750       else
9751         itl1=ntortyp+1
9752       endif
9753 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9754 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9755 !d     & ' itl',itl,' itl1',itl1
9756 #ifdef MOMENT
9757       if (imat.eq.1) then
9758         s1=dip(3,jj,i)*dip(3,kk,k)
9759       else
9760         s1=dip(2,jj,j)*dip(2,kk,l)
9761       endif
9762 #endif
9763       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9764       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9765       if (j.eq.l+1) then
9766         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9767         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9768       else
9769         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9770         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9771       endif
9772       call transpose2(EUg(1,1,k),auxmat(1,1))
9773       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9774       vv(1)=pizda(1,1)-pizda(2,2)
9775       vv(2)=pizda(2,1)+pizda(1,2)
9776       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9777 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9778 #ifdef MOMENT
9779       eello6_graph4=-(s1+s2+s3+s4)
9780 #else
9781       eello6_graph4=-(s2+s3+s4)
9782 #endif
9783 ! Derivatives in gamma(i-1)
9784       if (i.gt.1) then
9785 #ifdef MOMENT
9786         if (imat.eq.1) then
9787           s1=dipderg(2,jj,i)*dip(3,kk,k)
9788         else
9789           s1=dipderg(4,jj,j)*dip(2,kk,l)
9790         endif
9791 #endif
9792         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9793         if (j.eq.l+1) then
9794           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9795           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9796         else
9797           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9798           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9799         endif
9800         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9801         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9802 !d          write (2,*) 'turn6 derivatives'
9803 #ifdef MOMENT
9804           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9805 #else
9806           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9807 #endif
9808         else
9809 #ifdef MOMENT
9810           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9811 #else
9812           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9813 #endif
9814         endif
9815       endif
9816 ! Derivatives in gamma(k-1)
9817 #ifdef MOMENT
9818       if (imat.eq.1) then
9819         s1=dip(3,jj,i)*dipderg(2,kk,k)
9820       else
9821         s1=dip(2,jj,j)*dipderg(4,kk,l)
9822       endif
9823 #endif
9824       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9825       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9826       if (j.eq.l+1) then
9827         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9828         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9829       else
9830         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9831         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9832       endif
9833       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9834       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9835       vv(1)=pizda(1,1)-pizda(2,2)
9836       vv(2)=pizda(2,1)+pizda(1,2)
9837       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9838       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9839 #ifdef MOMENT
9840         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9841 #else
9842         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9843 #endif
9844       else
9845 #ifdef MOMENT
9846         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9847 #else
9848         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9849 #endif
9850       endif
9851 ! Derivatives in gamma(j-1) or gamma(l-1)
9852       if (l.eq.j+1 .and. l.gt.1) then
9853         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9854         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9855         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9856         vv(1)=pizda(1,1)-pizda(2,2)
9857         vv(2)=pizda(2,1)+pizda(1,2)
9858         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9859         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9860       else if (j.gt.1) then
9861         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9862         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9863         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9864         vv(1)=pizda(1,1)-pizda(2,2)
9865         vv(2)=pizda(2,1)+pizda(1,2)
9866         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9867         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9868           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9869         else
9870           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9871         endif
9872       endif
9873 ! Cartesian derivatives.
9874       do iii=1,2
9875         do kkk=1,5
9876           do lll=1,3
9877 #ifdef MOMENT
9878             if (iii.eq.1) then
9879               if (imat.eq.1) then
9880                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9881               else
9882                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9883               endif
9884             else
9885               if (imat.eq.1) then
9886                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9887               else
9888                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9889               endif
9890             endif
9891 #endif
9892             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9893               auxvec(1))
9894             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9895             if (j.eq.l+1) then
9896               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9897                 b1(1,itj1),auxvec(1))
9898               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9899             else
9900               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9901                 b1(1,itl1),auxvec(1))
9902               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9903             endif
9904             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9905               pizda(1,1))
9906             vv(1)=pizda(1,1)-pizda(2,2)
9907             vv(2)=pizda(2,1)+pizda(1,2)
9908             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9909             if (swap) then
9910               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9911 #ifdef MOMENT
9912                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9913                    -(s1+s2+s4)
9914 #else
9915                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9916                    -(s2+s4)
9917 #endif
9918                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9919               else
9920 #ifdef MOMENT
9921                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9922 #else
9923                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9924 #endif
9925                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9926               endif
9927             else
9928 #ifdef MOMENT
9929               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9930 #else
9931               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9932 #endif
9933               if (l.eq.j+1) then
9934                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9935               else
9936                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9937               endif
9938             endif
9939           enddo
9940         enddo
9941       enddo
9942       return
9943       end function eello6_graph4
9944 !-----------------------------------------------------------------------------
9945       real(kind=8) function eello_turn6(i,jj,kk)
9946 !      implicit real*8 (a-h,o-z)
9947 !      include 'DIMENSIONS'
9948 !      include 'COMMON.IOUNITS'
9949 !      include 'COMMON.CHAIN'
9950 !      include 'COMMON.DERIV'
9951 !      include 'COMMON.INTERACT'
9952 !      include 'COMMON.CONTACTS'
9953 !      include 'COMMON.TORSION'
9954 !      include 'COMMON.VAR'
9955 !      include 'COMMON.GEO'
9956       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9957       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9958       real(kind=8),dimension(3) :: ggg1,ggg2
9959       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9960       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9961 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9962 !           the respective energy moment and not to the cluster cumulant.
9963 !el local variables
9964       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9965       integer :: j1,j2,l1,l2,ll
9966       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9967       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9968       s1=0.0d0
9969       s8=0.0d0
9970       s13=0.0d0
9971 !
9972       eello_turn6=0.0d0
9973       j=i+4
9974       k=i+1
9975       l=i+3
9976       iti=itortyp(itype(i,1))
9977       itk=itortyp(itype(k,1))
9978       itk1=itortyp(itype(k+1,1))
9979       itl=itortyp(itype(l,1))
9980       itj=itortyp(itype(j,1))
9981 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9982 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9983 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9984 !d        eello6=0.0d0
9985 !d        return
9986 !d      endif
9987 !d      write (iout,*)
9988 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9989 !d     &   ' and',k,l
9990 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9991       do iii=1,2
9992         do kkk=1,5
9993           do lll=1,3
9994             derx_turn(lll,kkk,iii)=0.0d0
9995           enddo
9996         enddo
9997       enddo
9998 !d      eij=1.0d0
9999 !d      ekl=1.0d0
10000 !d      ekont=1.0d0
10001       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10002 !d      eello6_5=0.0d0
10003 !d      write (2,*) 'eello6_5',eello6_5
10004 #ifdef MOMENT
10005       call transpose2(AEA(1,1,1),auxmat(1,1))
10006       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10007       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10008       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10009 #endif
10010       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10011       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10012       s2 = scalar2(b1(1,itk),vtemp1(1))
10013 #ifdef MOMENT
10014       call transpose2(AEA(1,1,2),atemp(1,1))
10015       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10016       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10017       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10018 #endif
10019       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10020       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10021       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10022 #ifdef MOMENT
10023       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10024       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10025       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10026       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10027       ss13 = scalar2(b1(1,itk),vtemp4(1))
10028       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10029 #endif
10030 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10031 !      s1=0.0d0
10032 !      s2=0.0d0
10033 !      s8=0.0d0
10034 !      s12=0.0d0
10035 !      s13=0.0d0
10036       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10037 ! Derivatives in gamma(i+2)
10038       s1d =0.0d0
10039       s8d =0.0d0
10040 #ifdef MOMENT
10041       call transpose2(AEA(1,1,1),auxmatd(1,1))
10042       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10043       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10044       call transpose2(AEAderg(1,1,2),atempd(1,1))
10045       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10046       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10047 #endif
10048       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10049       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10050       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10051 !      s1d=0.0d0
10052 !      s2d=0.0d0
10053 !      s8d=0.0d0
10054 !      s12d=0.0d0
10055 !      s13d=0.0d0
10056       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10057 ! Derivatives in gamma(i+3)
10058 #ifdef MOMENT
10059       call transpose2(AEA(1,1,1),auxmatd(1,1))
10060       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10061       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10062       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10063 #endif
10064       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10065       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10066       s2d = scalar2(b1(1,itk),vtemp1d(1))
10067 #ifdef MOMENT
10068       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10069       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10070 #endif
10071       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10072 #ifdef MOMENT
10073       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10074       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10075       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10076 #endif
10077 !      s1d=0.0d0
10078 !      s2d=0.0d0
10079 !      s8d=0.0d0
10080 !      s12d=0.0d0
10081 !      s13d=0.0d0
10082 #ifdef MOMENT
10083       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10084                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10085 #else
10086       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10087                     -0.5d0*ekont*(s2d+s12d)
10088 #endif
10089 ! Derivatives in gamma(i+4)
10090       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10091       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10092       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10093 #ifdef MOMENT
10094       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10095       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10096       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10097 #endif
10098 !      s1d=0.0d0
10099 !      s2d=0.0d0
10100 !      s8d=0.0d0
10101 !      s12d=0.0d0
10102 !      s13d=0.0d0
10103 #ifdef MOMENT
10104       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10105 #else
10106       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10107 #endif
10108 ! Derivatives in gamma(i+5)
10109 #ifdef MOMENT
10110       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10111       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10112       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10113 #endif
10114       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10115       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10116       s2d = scalar2(b1(1,itk),vtemp1d(1))
10117 #ifdef MOMENT
10118       call transpose2(AEA(1,1,2),atempd(1,1))
10119       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10120       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10121 #endif
10122       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10123       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10124 #ifdef MOMENT
10125       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10126       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10127       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10128 #endif
10129 !      s1d=0.0d0
10130 !      s2d=0.0d0
10131 !      s8d=0.0d0
10132 !      s12d=0.0d0
10133 !      s13d=0.0d0
10134 #ifdef MOMENT
10135       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10136                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10137 #else
10138       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10139                     -0.5d0*ekont*(s2d+s12d)
10140 #endif
10141 ! Cartesian derivatives
10142       do iii=1,2
10143         do kkk=1,5
10144           do lll=1,3
10145 #ifdef MOMENT
10146             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10147             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10148             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10149 #endif
10150             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10151             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10152                 vtemp1d(1))
10153             s2d = scalar2(b1(1,itk),vtemp1d(1))
10154 #ifdef MOMENT
10155             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10156             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10157             s8d = -(atempd(1,1)+atempd(2,2))* &
10158                  scalar2(cc(1,1,itl),vtemp2(1))
10159 #endif
10160             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10161                  auxmatd(1,1))
10162             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10163             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10164 !      s1d=0.0d0
10165 !      s2d=0.0d0
10166 !      s8d=0.0d0
10167 !      s12d=0.0d0
10168 !      s13d=0.0d0
10169 #ifdef MOMENT
10170             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10171               - 0.5d0*(s1d+s2d)
10172 #else
10173             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10174               - 0.5d0*s2d
10175 #endif
10176 #ifdef MOMENT
10177             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10178               - 0.5d0*(s8d+s12d)
10179 #else
10180             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10181               - 0.5d0*s12d
10182 #endif
10183           enddo
10184         enddo
10185       enddo
10186 #ifdef MOMENT
10187       do kkk=1,5
10188         do lll=1,3
10189           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10190             achuj_tempd(1,1))
10191           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10192           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10193           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10194           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10195           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10196             vtemp4d(1))
10197           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10198           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10199           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10200         enddo
10201       enddo
10202 #endif
10203 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10204 !d     &  16*eel_turn6_num
10205 !d      goto 1112
10206       if (j.lt.nres-1) then
10207         j1=j+1
10208         j2=j-1
10209       else
10210         j1=j-1
10211         j2=j-2
10212       endif
10213       if (l.lt.nres-1) then
10214         l1=l+1
10215         l2=l-1
10216       else
10217         l1=l-1
10218         l2=l-2
10219       endif
10220       do ll=1,3
10221 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10222 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10223 !grad        ghalf=0.5d0*ggg1(ll)
10224 !d        ghalf=0.0d0
10225         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10226         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10227         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10228           +ekont*derx_turn(ll,2,1)
10229         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10230         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10231           +ekont*derx_turn(ll,4,1)
10232         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10233         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10234         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10235 !grad        ghalf=0.5d0*ggg2(ll)
10236 !d        ghalf=0.0d0
10237         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10238           +ekont*derx_turn(ll,2,2)
10239         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10240         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10241           +ekont*derx_turn(ll,4,2)
10242         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10243         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10244         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10245       enddo
10246 !d      goto 1112
10247 !grad      do m=i+1,j-1
10248 !grad        do ll=1,3
10249 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10250 !grad        enddo
10251 !grad      enddo
10252 !grad      do m=k+1,l-1
10253 !grad        do ll=1,3
10254 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10255 !grad        enddo
10256 !grad      enddo
10257 !grad1112  continue
10258 !grad      do m=i+2,j2
10259 !grad        do ll=1,3
10260 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10261 !grad        enddo
10262 !grad      enddo
10263 !grad      do m=k+2,l2
10264 !grad        do ll=1,3
10265 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10266 !grad        enddo
10267 !grad      enddo
10268 !d      do iii=1,nres-3
10269 !d        write (2,*) iii,g_corr6_loc(iii)
10270 !d      enddo
10271       eello_turn6=ekont*eel_turn6
10272 !d      write (2,*) 'ekont',ekont
10273 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10274       return
10275       end function eello_turn6
10276 !-----------------------------------------------------------------------------
10277       subroutine MATVEC2(A1,V1,V2)
10278 !DIR$ INLINEALWAYS MATVEC2
10279 #ifndef OSF
10280 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10281 #endif
10282 !      implicit real*8 (a-h,o-z)
10283 !      include 'DIMENSIONS'
10284       real(kind=8),dimension(2) :: V1,V2
10285       real(kind=8),dimension(2,2) :: A1
10286       real(kind=8) :: vaux1,vaux2
10287 !      DO 1 I=1,2
10288 !        VI=0.0
10289 !        DO 3 K=1,2
10290 !    3     VI=VI+A1(I,K)*V1(K)
10291 !        Vaux(I)=VI
10292 !    1 CONTINUE
10293
10294       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10295       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10296
10297       v2(1)=vaux1
10298       v2(2)=vaux2
10299       end subroutine MATVEC2
10300 !-----------------------------------------------------------------------------
10301       subroutine MATMAT2(A1,A2,A3)
10302 #ifndef OSF
10303 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10304 #endif
10305 !      implicit real*8 (a-h,o-z)
10306 !      include 'DIMENSIONS'
10307       real(kind=8),dimension(2,2) :: A1,A2,A3
10308       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10309 !      DIMENSION AI3(2,2)
10310 !        DO  J=1,2
10311 !          A3IJ=0.0
10312 !          DO K=1,2
10313 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10314 !          enddo
10315 !          A3(I,J)=A3IJ
10316 !       enddo
10317 !      enddo
10318
10319       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10320       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10321       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10322       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10323
10324       A3(1,1)=AI3_11
10325       A3(2,1)=AI3_21
10326       A3(1,2)=AI3_12
10327       A3(2,2)=AI3_22
10328       end subroutine MATMAT2
10329 !-----------------------------------------------------------------------------
10330       real(kind=8) function scalar2(u,v)
10331 !DIR$ INLINEALWAYS scalar2
10332       implicit none
10333       real(kind=8),dimension(2) :: u,v
10334       real(kind=8) :: sc
10335       integer :: i
10336       scalar2=u(1)*v(1)+u(2)*v(2)
10337       return
10338       end function scalar2
10339 !-----------------------------------------------------------------------------
10340       subroutine transpose2(a,at)
10341 !DIR$ INLINEALWAYS transpose2
10342 #ifndef OSF
10343 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10344 #endif
10345       implicit none
10346       real(kind=8),dimension(2,2) :: a,at
10347       at(1,1)=a(1,1)
10348       at(1,2)=a(2,1)
10349       at(2,1)=a(1,2)
10350       at(2,2)=a(2,2)
10351       return
10352       end subroutine transpose2
10353 !-----------------------------------------------------------------------------
10354       subroutine transpose(n,a,at)
10355       implicit none
10356       integer :: n,i,j
10357       real(kind=8),dimension(n,n) :: a,at
10358       do i=1,n
10359         do j=1,n
10360           at(j,i)=a(i,j)
10361         enddo
10362       enddo
10363       return
10364       end subroutine transpose
10365 !-----------------------------------------------------------------------------
10366       subroutine prodmat3(a1,a2,kk,transp,prod)
10367 !DIR$ INLINEALWAYS prodmat3
10368 #ifndef OSF
10369 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10370 #endif
10371       implicit none
10372       integer :: i,j
10373       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10374       logical :: transp
10375 !rc      double precision auxmat(2,2),prod_(2,2)
10376
10377       if (transp) then
10378 !rc        call transpose2(kk(1,1),auxmat(1,1))
10379 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10380 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10381
10382            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10383        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10384            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10385        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10386            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10387        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10388            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10389        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10390
10391       else
10392 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10393 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10394
10395            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10396         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10397            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10398         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10399            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10400         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10401            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10402         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10403
10404       endif
10405 !      call transpose2(a2(1,1),a2t(1,1))
10406
10407 !rc      print *,transp
10408 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10409 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10410
10411       return
10412       end subroutine prodmat3
10413 !-----------------------------------------------------------------------------
10414 ! energy_p_new_barrier.F
10415 !-----------------------------------------------------------------------------
10416       subroutine sum_gradient
10417 !      implicit real*8 (a-h,o-z)
10418       use io_base, only: pdbout
10419 !      include 'DIMENSIONS'
10420 #ifndef ISNAN
10421       external proc_proc
10422 #ifdef WINPGI
10423 !MS$ATTRIBUTES C ::  proc_proc
10424 #endif
10425 #endif
10426 #ifdef MPI
10427       include 'mpif.h'
10428 #endif
10429       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10430                    gloc_scbuf !(3,maxres)
10431
10432       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10433 !#endif
10434 !el local variables
10435       integer :: i,j,k,ierror,ierr
10436       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10437                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10438                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10439                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10440                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10441                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10442                    gsccorr_max,gsccorrx_max,time00
10443
10444 !      include 'COMMON.SETUP'
10445 !      include 'COMMON.IOUNITS'
10446 !      include 'COMMON.FFIELD'
10447 !      include 'COMMON.DERIV'
10448 !      include 'COMMON.INTERACT'
10449 !      include 'COMMON.SBRIDGE'
10450 !      include 'COMMON.CHAIN'
10451 !      include 'COMMON.VAR'
10452 !      include 'COMMON.CONTROL'
10453 !      include 'COMMON.TIME1'
10454 !      include 'COMMON.MAXGRAD'
10455 !      include 'COMMON.SCCOR'
10456 #ifdef TIMING
10457       time01=MPI_Wtime()
10458 #endif
10459 #ifdef DEBUG
10460       write (iout,*) "sum_gradient gvdwc, gvdwx"
10461       do i=1,nres
10462         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10463          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10464       enddo
10465       call flush(iout)
10466 #endif
10467 #ifdef MPI
10468         gradbufc=0.0d0
10469         gradbufx=0.0d0
10470         gradbufc_sum=0.0d0
10471         gloc_scbuf=0.0d0
10472         glocbuf=0.0d0
10473 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10474         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10475           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10476 #endif
10477 !
10478 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10479 !            in virtual-bond-vector coordinates
10480 !
10481 #ifdef DEBUG
10482 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10483 !      do i=1,nres-1
10484 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10485 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10486 !      enddo
10487 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10488 !      do i=1,nres-1
10489 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10490 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10491 !      enddo
10492       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10493       do i=1,nres
10494         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10495          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10496          (gvdwc_scpp(j,i),j=1,3)
10497       enddo
10498       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10499       do i=1,nres
10500         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10501          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10502          (gelc_loc_long(j,i),j=1,3)
10503       enddo
10504       call flush(iout)
10505 #endif
10506 #ifdef SPLITELE
10507       do i=0,nct
10508         do j=1,3
10509           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10510                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10511                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10512                       wel_loc*gel_loc_long(j,i)+ &
10513                       wcorr*gradcorr_long(j,i)+ &
10514                       wcorr5*gradcorr5_long(j,i)+ &
10515                       wcorr6*gradcorr6_long(j,i)+ &
10516                       wturn6*gcorr6_turn_long(j,i)+ &
10517                       wstrain*ghpbc(j,i) &
10518                      +wliptran*gliptranc(j,i) &
10519                      +gradafm(j,i) &
10520                      +welec*gshieldc(j,i) &
10521                      +wcorr*gshieldc_ec(j,i) &
10522                      +wturn3*gshieldc_t3(j,i)&
10523                      +wturn4*gshieldc_t4(j,i)&
10524                      +wel_loc*gshieldc_ll(j,i)&
10525                      +wtube*gg_tube(j,i) &
10526                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10527                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10528                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10529                      wcorr_nucl*gradcorr_nucl(j,i)&
10530                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10531                      wcatprot* gradpepcat(j,i)+ &
10532                      wcatcat*gradcatcat(j,i)+   &
10533                      wscbase*gvdwc_scbase(j,i)+ &
10534                      wpepbase*gvdwc_pepbase(j,i)+&
10535                      wscpho*gvdwc_scpho(j,i)+   &
10536                      wpeppho*gvdwc_peppho(j,i)
10537
10538
10539
10540
10541
10542         enddo
10543       enddo
10544 #else
10545       do i=0,nct
10546         do j=1,3
10547           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10548                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10549                       welec*gelc_long(j,i)+ &
10550                       wbond*gradb(j,i)+ &
10551                       wel_loc*gel_loc_long(j,i)+ &
10552                       wcorr*gradcorr_long(j,i)+ &
10553                       wcorr5*gradcorr5_long(j,i)+ &
10554                       wcorr6*gradcorr6_long(j,i)+ &
10555                       wturn6*gcorr6_turn_long(j,i)+ &
10556                       wstrain*ghpbc(j,i) &
10557                      +wliptran*gliptranc(j,i) &
10558                      +gradafm(j,i) &
10559                      +welec*gshieldc(j,i)&
10560                      +wcorr*gshieldc_ec(j,i) &
10561                      +wturn4*gshieldc_t4(j,i) &
10562                      +wel_loc*gshieldc_ll(j,i)&
10563                      +wtube*gg_tube(j,i) &
10564                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10565                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10566                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10567                      wcorr_nucl*gradcorr_nucl(j,i) &
10568                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10569                      wcatprot* gradpepcat(j,i)+ &
10570                      wcatcat*gradcatcat(j,i)+   &
10571                      wscbase*gvdwc_scbase(j,i)  &
10572                      wpepbase*gvdwc_pepbase(j,i)+&
10573                      wscpho*gvdwc_scpho(j,i)+&
10574                      wpeppho*gvdwc_peppho(j,i)
10575
10576
10577         enddo
10578       enddo
10579 #endif
10580 #ifdef MPI
10581       if (nfgtasks.gt.1) then
10582       time00=MPI_Wtime()
10583 #ifdef DEBUG
10584       write (iout,*) "gradbufc before allreduce"
10585       do i=1,nres
10586         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10587       enddo
10588       call flush(iout)
10589 #endif
10590       do i=0,nres
10591         do j=1,3
10592           gradbufc_sum(j,i)=gradbufc(j,i)
10593         enddo
10594       enddo
10595 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10596 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10597 !      time_reduce=time_reduce+MPI_Wtime()-time00
10598 #ifdef DEBUG
10599 !      write (iout,*) "gradbufc_sum after allreduce"
10600 !      do i=1,nres
10601 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10602 !      enddo
10603 !      call flush(iout)
10604 #endif
10605 #ifdef TIMING
10606 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10607 #endif
10608       do i=0,nres
10609         do k=1,3
10610           gradbufc(k,i)=0.0d0
10611         enddo
10612       enddo
10613 #ifdef DEBUG
10614       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10615       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10616                         " jgrad_end  ",jgrad_end(i),&
10617                         i=igrad_start,igrad_end)
10618 #endif
10619 !
10620 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10621 ! do not parallelize this part.
10622 !
10623 !      do i=igrad_start,igrad_end
10624 !        do j=jgrad_start(i),jgrad_end(i)
10625 !          do k=1,3
10626 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10627 !          enddo
10628 !        enddo
10629 !      enddo
10630       do j=1,3
10631         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10632       enddo
10633       do i=nres-2,-1,-1
10634         do j=1,3
10635           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10636         enddo
10637       enddo
10638 #ifdef DEBUG
10639       write (iout,*) "gradbufc after summing"
10640       do i=1,nres
10641         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10642       enddo
10643       call flush(iout)
10644 #endif
10645       else
10646 #endif
10647 !el#define DEBUG
10648 #ifdef DEBUG
10649       write (iout,*) "gradbufc"
10650       do i=1,nres
10651         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10652       enddo
10653       call flush(iout)
10654 #endif
10655 !el#undef DEBUG
10656       do i=-1,nres
10657         do j=1,3
10658           gradbufc_sum(j,i)=gradbufc(j,i)
10659           gradbufc(j,i)=0.0d0
10660         enddo
10661       enddo
10662       do j=1,3
10663         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10664       enddo
10665       do i=nres-2,-1,-1
10666         do j=1,3
10667           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10668         enddo
10669       enddo
10670 !      do i=nnt,nres-1
10671 !        do k=1,3
10672 !          gradbufc(k,i)=0.0d0
10673 !        enddo
10674 !        do j=i+1,nres
10675 !          do k=1,3
10676 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10677 !          enddo
10678 !        enddo
10679 !      enddo
10680 !el#define DEBUG
10681 #ifdef DEBUG
10682       write (iout,*) "gradbufc after summing"
10683       do i=1,nres
10684         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10685       enddo
10686       call flush(iout)
10687 #endif
10688 !el#undef DEBUG
10689 #ifdef MPI
10690       endif
10691 #endif
10692       do k=1,3
10693         gradbufc(k,nres)=0.0d0
10694       enddo
10695 !el----------------
10696 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10697 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10698 !el-----------------
10699       do i=-1,nct
10700         do j=1,3
10701 #ifdef SPLITELE
10702           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10703                       wel_loc*gel_loc(j,i)+ &
10704                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10705                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10706                       wel_loc*gel_loc_long(j,i)+ &
10707                       wcorr*gradcorr_long(j,i)+ &
10708                       wcorr5*gradcorr5_long(j,i)+ &
10709                       wcorr6*gradcorr6_long(j,i)+ &
10710                       wturn6*gcorr6_turn_long(j,i))+ &
10711                       wbond*gradb(j,i)+ &
10712                       wcorr*gradcorr(j,i)+ &
10713                       wturn3*gcorr3_turn(j,i)+ &
10714                       wturn4*gcorr4_turn(j,i)+ &
10715                       wcorr5*gradcorr5(j,i)+ &
10716                       wcorr6*gradcorr6(j,i)+ &
10717                       wturn6*gcorr6_turn(j,i)+ &
10718                       wsccor*gsccorc(j,i) &
10719                      +wscloc*gscloc(j,i)  &
10720                      +wliptran*gliptranc(j,i) &
10721                      +gradafm(j,i) &
10722                      +welec*gshieldc(j,i) &
10723                      +welec*gshieldc_loc(j,i) &
10724                      +wcorr*gshieldc_ec(j,i) &
10725                      +wcorr*gshieldc_loc_ec(j,i) &
10726                      +wturn3*gshieldc_t3(j,i) &
10727                      +wturn3*gshieldc_loc_t3(j,i) &
10728                      +wturn4*gshieldc_t4(j,i) &
10729                      +wturn4*gshieldc_loc_t4(j,i) &
10730                      +wel_loc*gshieldc_ll(j,i) &
10731                      +wel_loc*gshieldc_loc_ll(j,i) &
10732                      +wtube*gg_tube(j,i) &
10733                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10734                      +wvdwpsb*gvdwpsb1(j,i))&
10735                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10736
10737 !                 if ((i.le.2).and.(i.ge.1))
10738 !                       print *,gradc(j,i,icg),&
10739 !                      gradbufc(j,i),welec*gelc(j,i), &
10740 !                      wel_loc*gel_loc(j,i), &
10741 !                      wscp*gvdwc_scpp(j,i), &
10742 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10743 !                      wel_loc*gel_loc_long(j,i), &
10744 !                      wcorr*gradcorr_long(j,i), &
10745 !                      wcorr5*gradcorr5_long(j,i), &
10746 !                      wcorr6*gradcorr6_long(j,i), &
10747 !                      wturn6*gcorr6_turn_long(j,i), &
10748 !                      wbond*gradb(j,i), &
10749 !                      wcorr*gradcorr(j,i), &
10750 !                      wturn3*gcorr3_turn(j,i), &
10751 !                      wturn4*gcorr4_turn(j,i), &
10752 !                      wcorr5*gradcorr5(j,i), &
10753 !                      wcorr6*gradcorr6(j,i), &
10754 !                      wturn6*gcorr6_turn(j,i), &
10755 !                      wsccor*gsccorc(j,i) &
10756 !                     ,wscloc*gscloc(j,i)  &
10757 !                     ,wliptran*gliptranc(j,i) &
10758 !                    ,gradafm(j,i) &
10759 !                     ,welec*gshieldc(j,i) &
10760 !                     ,welec*gshieldc_loc(j,i) &
10761 !                     ,wcorr*gshieldc_ec(j,i) &
10762 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10763 !                     ,wturn3*gshieldc_t3(j,i) &
10764 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10765 !                     ,wturn4*gshieldc_t4(j,i) &
10766 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10767 !                     ,wel_loc*gshieldc_ll(j,i) &
10768 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10769 !                     ,wtube*gg_tube(j,i) &
10770 !                     ,wbond_nucl*gradb_nucl(j,i) &
10771 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10772 !                     wvdwpsb*gvdwpsb1(j,i)&
10773 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10774 !
10775
10776 #else
10777           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10778                       wel_loc*gel_loc(j,i)+ &
10779                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10780                       welec*gelc_long(j,i)+ &
10781                       wel_loc*gel_loc_long(j,i)+ &
10782 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10783                       wcorr5*gradcorr5_long(j,i)+ &
10784                       wcorr6*gradcorr6_long(j,i)+ &
10785                       wturn6*gcorr6_turn_long(j,i))+ &
10786                       wbond*gradb(j,i)+ &
10787                       wcorr*gradcorr(j,i)+ &
10788                       wturn3*gcorr3_turn(j,i)+ &
10789                       wturn4*gcorr4_turn(j,i)+ &
10790                       wcorr5*gradcorr5(j,i)+ &
10791                       wcorr6*gradcorr6(j,i)+ &
10792                       wturn6*gcorr6_turn(j,i)+ &
10793                       wsccor*gsccorc(j,i) &
10794                      +wscloc*gscloc(j,i) &
10795                      +gradafm(j,i) &
10796                      +wliptran*gliptranc(j,i) &
10797                      +welec*gshieldc(j,i) &
10798                      +welec*gshieldc_loc(j,) &
10799                      +wcorr*gshieldc_ec(j,i) &
10800                      +wcorr*gshieldc_loc_ec(j,i) &
10801                      +wturn3*gshieldc_t3(j,i) &
10802                      +wturn3*gshieldc_loc_t3(j,i) &
10803                      +wturn4*gshieldc_t4(j,i) &
10804                      +wturn4*gshieldc_loc_t4(j,i) &
10805                      +wel_loc*gshieldc_ll(j,i) &
10806                      +wel_loc*gshieldc_loc_ll(j,i) &
10807                      +wtube*gg_tube(j,i) &
10808                      +wbond_nucl*gradb_nucl(j,i) &
10809                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10810                      +wvdwpsb*gvdwpsb1(j,i))&
10811                      +wsbloc*gsbloc(j,i)
10812
10813
10814
10815
10816 #endif
10817           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10818                         wbond*gradbx(j,i)+ &
10819                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10820                         wsccor*gsccorx(j,i) &
10821                        +wscloc*gsclocx(j,i) &
10822                        +wliptran*gliptranx(j,i) &
10823                        +welec*gshieldx(j,i)     &
10824                        +wcorr*gshieldx_ec(j,i)  &
10825                        +wturn3*gshieldx_t3(j,i) &
10826                        +wturn4*gshieldx_t4(j,i) &
10827                        +wel_loc*gshieldx_ll(j,i)&
10828                        +wtube*gg_tube_sc(j,i)   &
10829                        +wbond_nucl*gradbx_nucl(j,i) &
10830                        +wvdwsb*gvdwsbx(j,i) &
10831                        +welsb*gelsbx(j,i) &
10832                        +wcorr_nucl*gradxorr_nucl(j,i)&
10833                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10834                        +wsbloc*gsblocx(j,i) &
10835                        +wcatprot* gradpepcatx(j,i)&
10836                        +wscbase*gvdwx_scbase(j,i) &
10837                        +wpepbase*gvdwx_pepbase(j,i)&
10838                        +wscpho*gvdwx_scpho(j,i)
10839 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
10840
10841         enddo
10842       enddo
10843 #ifdef DEBUG
10844       write (iout,*) "gloc before adding corr"
10845       do i=1,4*nres
10846         write (iout,*) i,gloc(i,icg)
10847       enddo
10848 #endif
10849       do i=1,nres-3
10850         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10851          +wcorr5*g_corr5_loc(i) &
10852          +wcorr6*g_corr6_loc(i) &
10853          +wturn4*gel_loc_turn4(i) &
10854          +wturn3*gel_loc_turn3(i) &
10855          +wturn6*gel_loc_turn6(i) &
10856          +wel_loc*gel_loc_loc(i)
10857       enddo
10858 #ifdef DEBUG
10859       write (iout,*) "gloc after adding corr"
10860       do i=1,4*nres
10861         write (iout,*) i,gloc(i,icg)
10862       enddo
10863 #endif
10864 #ifdef MPI
10865       if (nfgtasks.gt.1) then
10866         do j=1,3
10867           do i=0,nres
10868             gradbufc(j,i)=gradc(j,i,icg)
10869             gradbufx(j,i)=gradx(j,i,icg)
10870           enddo
10871         enddo
10872         do i=1,4*nres
10873           glocbuf(i)=gloc(i,icg)
10874         enddo
10875 !#define DEBUG
10876 #ifdef DEBUG
10877       write (iout,*) "gloc_sc before reduce"
10878       do i=1,nres
10879        do j=1,1
10880         write (iout,*) i,j,gloc_sc(j,i,icg)
10881        enddo
10882       enddo
10883 #endif
10884 !#undef DEBUG
10885         do i=1,nres
10886          do j=1,3
10887           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10888          enddo
10889         enddo
10890         time00=MPI_Wtime()
10891         call MPI_Barrier(FG_COMM,IERR)
10892         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10893         time00=MPI_Wtime()
10894         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10895           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10896         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10897           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10898         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10899           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10900         time_reduce=time_reduce+MPI_Wtime()-time00
10901         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10902           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10903         time_reduce=time_reduce+MPI_Wtime()-time00
10904 !#define DEBUG
10905 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10906 #ifdef DEBUG
10907       write (iout,*) "gloc_sc after reduce"
10908       do i=1,nres
10909        do j=1,1
10910         write (iout,*) i,j,gloc_sc(j,i,icg)
10911        enddo
10912       enddo
10913 #endif
10914 !#undef DEBUG
10915 #ifdef DEBUG
10916       write (iout,*) "gloc after reduce"
10917       do i=1,4*nres
10918         write (iout,*) i,gloc(i,icg)
10919       enddo
10920 #endif
10921       endif
10922 #endif
10923       if (gnorm_check) then
10924 !
10925 ! Compute the maximum elements of the gradient
10926 !
10927       gvdwc_max=0.0d0
10928       gvdwc_scp_max=0.0d0
10929       gelc_max=0.0d0
10930       gvdwpp_max=0.0d0
10931       gradb_max=0.0d0
10932       ghpbc_max=0.0d0
10933       gradcorr_max=0.0d0
10934       gel_loc_max=0.0d0
10935       gcorr3_turn_max=0.0d0
10936       gcorr4_turn_max=0.0d0
10937       gradcorr5_max=0.0d0
10938       gradcorr6_max=0.0d0
10939       gcorr6_turn_max=0.0d0
10940       gsccorc_max=0.0d0
10941       gscloc_max=0.0d0
10942       gvdwx_max=0.0d0
10943       gradx_scp_max=0.0d0
10944       ghpbx_max=0.0d0
10945       gradxorr_max=0.0d0
10946       gsccorx_max=0.0d0
10947       gsclocx_max=0.0d0
10948       do i=1,nct
10949         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10950         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10951         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10952         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10953          gvdwc_scp_max=gvdwc_scp_norm
10954         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10955         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10956         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10957         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10958         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10959         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10960         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10961         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10962         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10963         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10964         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10965         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10966         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10967           gcorr3_turn(1,i)))
10968         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10969           gcorr3_turn_max=gcorr3_turn_norm
10970         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10971           gcorr4_turn(1,i)))
10972         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10973           gcorr4_turn_max=gcorr4_turn_norm
10974         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10975         if (gradcorr5_norm.gt.gradcorr5_max) &
10976           gradcorr5_max=gradcorr5_norm
10977         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10978         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10979         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10980           gcorr6_turn(1,i)))
10981         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10982           gcorr6_turn_max=gcorr6_turn_norm
10983         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10984         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10985         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10986         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10987         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10988         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10989         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10990         if (gradx_scp_norm.gt.gradx_scp_max) &
10991           gradx_scp_max=gradx_scp_norm
10992         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10993         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10994         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10995         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10996         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10997         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10998         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10999         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11000       enddo
11001       if (gradout) then
11002 #ifdef AIX
11003         open(istat,file=statname,position="append")
11004 #else
11005         open(istat,file=statname,access="append")
11006 #endif
11007         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11008            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11009            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11010            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11011            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11012            gsccorx_max,gsclocx_max
11013         close(istat)
11014         if (gvdwc_max.gt.1.0d4) then
11015           write (iout,*) "gvdwc gvdwx gradb gradbx"
11016           do i=nnt,nct
11017             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11018               gradb(j,i),gradbx(j,i),j=1,3)
11019           enddo
11020           call pdbout(0.0d0,'cipiszcze',iout)
11021           call flush(iout)
11022         endif
11023       endif
11024       endif
11025 !el#define DEBUG
11026 #ifdef DEBUG
11027       write (iout,*) "gradc gradx gloc"
11028       do i=1,nres
11029         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11030          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11031       enddo
11032 #endif
11033 !el#undef DEBUG
11034 #ifdef TIMING
11035       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11036 #endif
11037       return
11038       end subroutine sum_gradient
11039 !-----------------------------------------------------------------------------
11040       subroutine sc_grad
11041 !      implicit real*8 (a-h,o-z)
11042       use calc_data
11043 !      include 'DIMENSIONS'
11044 !      include 'COMMON.CHAIN'
11045 !      include 'COMMON.DERIV'
11046 !      include 'COMMON.CALC'
11047 !      include 'COMMON.IOUNITS'
11048       real(kind=8), dimension(3) :: dcosom1,dcosom2
11049 !      print *,"wchodze"
11050       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
11051       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
11052       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11053            -2.0D0*alf12*eps3der+sigder*sigsq_om12
11054 ! diagnostics only
11055 !      eom1=0.0d0
11056 !      eom2=0.0d0
11057 !      eom12=evdwij*eps1_om12
11058 ! end diagnostics
11059 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11060 !       " sigder",sigder
11061 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11062 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11063 !C      print *,sss_ele_cut,'in sc_grad'
11064       do k=1,3
11065         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11066         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11067       enddo
11068       do k=1,3
11069         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11070 !C      print *,'gg',k,gg(k)
11071        enddo
11072 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11073 !      write (iout,*) "gg",(gg(k),k=1,3)
11074       do k=1,3
11075         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11076                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11077                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11078                   *sss_ele_cut
11079
11080         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11081                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11082                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11083                   *sss_ele_cut
11084
11085 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11086 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11087 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11088 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11089       enddo
11090 !
11091 ! Calculate the components of the gradient in DC and X
11092 !
11093 !grad      do k=i,j-1
11094 !grad        do l=1,3
11095 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11096 !grad        enddo
11097 !grad      enddo
11098       do l=1,3
11099         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11100         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11101       enddo
11102       return
11103       end subroutine sc_grad
11104 #ifdef CRYST_THETA
11105 !-----------------------------------------------------------------------------
11106       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11107
11108       use comm_calcthet
11109 !      implicit real*8 (a-h,o-z)
11110 !      include 'DIMENSIONS'
11111 !      include 'COMMON.LOCAL'
11112 !      include 'COMMON.IOUNITS'
11113 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11114 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11115 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11116       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11117       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11118 !el      integer :: it
11119 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11120 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11121 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11122 !el local variables
11123
11124       delthec=thetai-thet_pred_mean
11125       delthe0=thetai-theta0i
11126 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11127       t3 = thetai-thet_pred_mean
11128       t6 = t3**2
11129       t9 = term1
11130       t12 = t3*sigcsq
11131       t14 = t12+t6*sigsqtc
11132       t16 = 1.0d0
11133       t21 = thetai-theta0i
11134       t23 = t21**2
11135       t26 = term2
11136       t27 = t21*t26
11137       t32 = termexp
11138       t40 = t32**2
11139       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11140        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11141        *(-t12*t9-ak*sig0inv*t27)
11142       return
11143       end subroutine mixder
11144 #endif
11145 !-----------------------------------------------------------------------------
11146 ! cartder.F
11147 !-----------------------------------------------------------------------------
11148       subroutine cartder
11149 !-----------------------------------------------------------------------------
11150 ! This subroutine calculates the derivatives of the consecutive virtual
11151 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11152 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11153 ! in the angles alpha and omega, describing the location of a side chain
11154 ! in its local coordinate system.
11155 !
11156 ! The derivatives are stored in the following arrays:
11157 !
11158 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11159 ! The structure is as follows:
11160 !
11161 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11162 ! 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)
11163 !         . . . . . . . . . . . .  . . . . . .
11164 ! 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)
11165 !                          .
11166 !                          .
11167 !                          .
11168 ! 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)
11169 !
11170 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11171 ! The structure is same as above.
11172 !
11173 ! DCDS - the derivatives of the side chain vectors in the local spherical
11174 ! andgles alph and omega:
11175 !
11176 ! 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)
11177 ! 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)
11178 !                          .
11179 !                          .
11180 !                          .
11181 ! 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)
11182 !
11183 ! Version of March '95, based on an early version of November '91.
11184 !
11185 !**********************************************************************
11186 !      implicit real*8 (a-h,o-z)
11187 !      include 'DIMENSIONS'
11188 !      include 'COMMON.VAR'
11189 !      include 'COMMON.CHAIN'
11190 !      include 'COMMON.DERIV'
11191 !      include 'COMMON.GEO'
11192 !      include 'COMMON.LOCAL'
11193 !      include 'COMMON.INTERACT'
11194       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11195       real(kind=8),dimension(3,3) :: dp,temp
11196 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11197       real(kind=8),dimension(3) :: xx,xx1
11198 !el local variables
11199       integer :: i,k,l,j,m,ind,ind1,jjj
11200       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11201                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11202                  sint2,xp,yp,xxp,yyp,zzp,dj
11203
11204 !      common /przechowalnia/ fromto
11205       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11206 ! get the position of the jth ijth fragment of the chain coordinate system
11207 ! in the fromto array.
11208 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11209 !
11210 !      maxdim=(nres-1)*(nres-2)/2
11211 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11212 ! calculate the derivatives of transformation matrix elements in theta
11213 !
11214
11215 !el      call flush(iout) !el
11216       do i=1,nres-2
11217         rdt(1,1,i)=-rt(1,2,i)
11218         rdt(1,2,i)= rt(1,1,i)
11219         rdt(1,3,i)= 0.0d0
11220         rdt(2,1,i)=-rt(2,2,i)
11221         rdt(2,2,i)= rt(2,1,i)
11222         rdt(2,3,i)= 0.0d0
11223         rdt(3,1,i)=-rt(3,2,i)
11224         rdt(3,2,i)= rt(3,1,i)
11225         rdt(3,3,i)= 0.0d0
11226       enddo
11227 !
11228 ! derivatives in phi
11229 !
11230       do i=2,nres-2
11231         drt(1,1,i)= 0.0d0
11232         drt(1,2,i)= 0.0d0
11233         drt(1,3,i)= 0.0d0
11234         drt(2,1,i)= rt(3,1,i)
11235         drt(2,2,i)= rt(3,2,i)
11236         drt(2,3,i)= rt(3,3,i)
11237         drt(3,1,i)=-rt(2,1,i)
11238         drt(3,2,i)=-rt(2,2,i)
11239         drt(3,3,i)=-rt(2,3,i)
11240       enddo
11241 !
11242 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11243 !
11244       do i=2,nres-2
11245         ind=indmat(i,i+1)
11246         do k=1,3
11247           do l=1,3
11248             temp(k,l)=rt(k,l,i)
11249           enddo
11250         enddo
11251         do k=1,3
11252           do l=1,3
11253             fromto(k,l,ind)=temp(k,l)
11254           enddo
11255         enddo
11256         do j=i+1,nres-2
11257           ind=indmat(i,j+1)
11258           do k=1,3
11259             do l=1,3
11260               dpkl=0.0d0
11261               do m=1,3
11262                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11263               enddo
11264               dp(k,l)=dpkl
11265               fromto(k,l,ind)=dpkl
11266             enddo
11267           enddo
11268           do k=1,3
11269             do l=1,3
11270               temp(k,l)=dp(k,l)
11271             enddo
11272           enddo
11273         enddo
11274       enddo
11275 !
11276 ! Calculate derivatives.
11277 !
11278       ind1=0
11279       do i=1,nres-2
11280       ind1=ind1+1
11281 !
11282 ! Derivatives of DC(i+1) in theta(i+2)
11283 !
11284         do j=1,3
11285           do k=1,2
11286             dpjk=0.0D0
11287             do l=1,3
11288               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11289             enddo
11290             dp(j,k)=dpjk
11291             prordt(j,k,i)=dp(j,k)
11292           enddo
11293           dp(j,3)=0.0D0
11294           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11295         enddo
11296 !
11297 ! Derivatives of SC(i+1) in theta(i+2)
11298 !
11299         xx1(1)=-0.5D0*xloc(2,i+1)
11300         xx1(2)= 0.5D0*xloc(1,i+1)
11301         do j=1,3
11302           xj=0.0D0
11303           do k=1,2
11304             xj=xj+r(j,k,i)*xx1(k)
11305           enddo
11306           xx(j)=xj
11307         enddo
11308         do j=1,3
11309           rj=0.0D0
11310           do k=1,3
11311             rj=rj+prod(j,k,i)*xx(k)
11312           enddo
11313           dxdv(j,ind1)=rj
11314         enddo
11315 !
11316 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11317 ! than the other off-diagonal derivatives.
11318 !
11319         do j=1,3
11320           dxoiij=0.0D0
11321           do k=1,3
11322             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11323           enddo
11324           dxdv(j,ind1+1)=dxoiij
11325         enddo
11326 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11327 !
11328 ! Derivatives of DC(i+1) in phi(i+2)
11329 !
11330         do j=1,3
11331           do k=1,3
11332             dpjk=0.0
11333             do l=2,3
11334               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11335             enddo
11336             dp(j,k)=dpjk
11337             prodrt(j,k,i)=dp(j,k)
11338           enddo
11339           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11340         enddo
11341 !
11342 ! Derivatives of SC(i+1) in phi(i+2)
11343 !
11344         xx(1)= 0.0D0
11345         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11346         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11347         do j=1,3
11348           rj=0.0D0
11349           do k=2,3
11350             rj=rj+prod(j,k,i)*xx(k)
11351           enddo
11352           dxdv(j+3,ind1)=-rj
11353         enddo
11354 !
11355 ! Derivatives of SC(i+1) in phi(i+3).
11356 !
11357         do j=1,3
11358           dxoiij=0.0D0
11359           do k=1,3
11360             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11361           enddo
11362           dxdv(j+3,ind1+1)=dxoiij
11363         enddo
11364 !
11365 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11366 ! theta(nres) and phi(i+3) thru phi(nres).
11367 !
11368         do j=i+1,nres-2
11369         ind1=ind1+1
11370         ind=indmat(i+1,j+1)
11371 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11372           do k=1,3
11373             do l=1,3
11374               tempkl=0.0D0
11375               do m=1,2
11376                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11377               enddo
11378               temp(k,l)=tempkl
11379             enddo
11380           enddo
11381 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11382 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11383 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11384 ! Derivatives of virtual-bond vectors in theta
11385           do k=1,3
11386             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11387           enddo
11388 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11389 ! Derivatives of SC vectors in theta
11390           do k=1,3
11391             dxoijk=0.0D0
11392             do l=1,3
11393               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11394             enddo
11395             dxdv(k,ind1+1)=dxoijk
11396           enddo
11397 !
11398 !--- Calculate the derivatives in phi
11399 !
11400           do k=1,3
11401             do l=1,3
11402               tempkl=0.0D0
11403               do m=1,3
11404                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11405               enddo
11406               temp(k,l)=tempkl
11407             enddo
11408           enddo
11409           do k=1,3
11410             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11411         enddo
11412           do k=1,3
11413             dxoijk=0.0D0
11414             do l=1,3
11415               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11416             enddo
11417             dxdv(k+3,ind1+1)=dxoijk
11418           enddo
11419         enddo
11420       enddo
11421 !
11422 ! Derivatives in alpha and omega:
11423 !
11424       do i=2,nres-1
11425 !       dsci=dsc(itype(i,1))
11426         dsci=vbld(i+nres)
11427 #ifdef OSF
11428         alphi=alph(i)
11429         omegi=omeg(i)
11430         if(alphi.ne.alphi) alphi=100.0
11431         if(omegi.ne.omegi) omegi=-100.0
11432 #else
11433       alphi=alph(i)
11434       omegi=omeg(i)
11435 #endif
11436 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11437       cosalphi=dcos(alphi)
11438       sinalphi=dsin(alphi)
11439       cosomegi=dcos(omegi)
11440       sinomegi=dsin(omegi)
11441       temp(1,1)=-dsci*sinalphi
11442       temp(2,1)= dsci*cosalphi*cosomegi
11443       temp(3,1)=-dsci*cosalphi*sinomegi
11444       temp(1,2)=0.0D0
11445       temp(2,2)=-dsci*sinalphi*sinomegi
11446       temp(3,2)=-dsci*sinalphi*cosomegi
11447       theta2=pi-0.5D0*theta(i+1)
11448       cost2=dcos(theta2)
11449       sint2=dsin(theta2)
11450       jjj=0
11451 !d      print *,((temp(l,k),l=1,3),k=1,2)
11452         do j=1,2
11453         xp=temp(1,j)
11454         yp=temp(2,j)
11455         xxp= xp*cost2+yp*sint2
11456         yyp=-xp*sint2+yp*cost2
11457         zzp=temp(3,j)
11458         xx(1)=xxp
11459         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11460         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11461         do k=1,3
11462           dj=0.0D0
11463           do l=1,3
11464             dj=dj+prod(k,l,i-1)*xx(l)
11465             enddo
11466           dxds(jjj+k,i)=dj
11467           enddo
11468         jjj=jjj+3
11469       enddo
11470       enddo
11471       return
11472       end subroutine cartder
11473 !-----------------------------------------------------------------------------
11474 ! checkder_p.F
11475 !-----------------------------------------------------------------------------
11476       subroutine check_cartgrad
11477 ! Check the gradient of Cartesian coordinates in internal coordinates.
11478 !      implicit real*8 (a-h,o-z)
11479 !      include 'DIMENSIONS'
11480 !      include 'COMMON.IOUNITS'
11481 !      include 'COMMON.VAR'
11482 !      include 'COMMON.CHAIN'
11483 !      include 'COMMON.GEO'
11484 !      include 'COMMON.LOCAL'
11485 !      include 'COMMON.DERIV'
11486       real(kind=8),dimension(6,nres) :: temp
11487       real(kind=8),dimension(3) :: xx,gg
11488       integer :: i,k,j,ii
11489       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11490 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11491 !
11492 ! Check the gradient of the virtual-bond and SC vectors in the internal
11493 ! coordinates.
11494 !
11495       aincr=1.0d-6
11496       aincr2=5.0d-7
11497       call cartder
11498       write (iout,'(a)') '**************** dx/dalpha'
11499       write (iout,'(a)')
11500       do i=2,nres-1
11501       alphi=alph(i)
11502       alph(i)=alph(i)+aincr
11503       do k=1,3
11504         temp(k,i)=dc(k,nres+i)
11505         enddo
11506       call chainbuild
11507       do k=1,3
11508         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11509         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11510         enddo
11511         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11512         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11513         write (iout,'(a)')
11514       alph(i)=alphi
11515       call chainbuild
11516       enddo
11517       write (iout,'(a)')
11518       write (iout,'(a)') '**************** dx/domega'
11519       write (iout,'(a)')
11520       do i=2,nres-1
11521       omegi=omeg(i)
11522       omeg(i)=omeg(i)+aincr
11523       do k=1,3
11524         temp(k,i)=dc(k,nres+i)
11525         enddo
11526       call chainbuild
11527       do k=1,3
11528           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11529           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11530                 (aincr*dabs(dxds(k+3,i))+aincr))
11531         enddo
11532         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11533             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11534         write (iout,'(a)')
11535       omeg(i)=omegi
11536       call chainbuild
11537       enddo
11538       write (iout,'(a)')
11539       write (iout,'(a)') '**************** dx/dtheta'
11540       write (iout,'(a)')
11541       do i=3,nres
11542       theti=theta(i)
11543         theta(i)=theta(i)+aincr
11544         do j=i-1,nres-1
11545           do k=1,3
11546             temp(k,j)=dc(k,nres+j)
11547           enddo
11548         enddo
11549         call chainbuild
11550         do j=i-1,nres-1
11551         ii = indmat(i-2,j)
11552 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11553         do k=1,3
11554           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11555           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11556                   (aincr*dabs(dxdv(k,ii))+aincr))
11557           enddo
11558           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11559               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11560           write(iout,'(a)')
11561         enddo
11562         write (iout,'(a)')
11563         theta(i)=theti
11564         call chainbuild
11565       enddo
11566       write (iout,'(a)') '***************** dx/dphi'
11567       write (iout,'(a)')
11568       do i=4,nres
11569         phi(i)=phi(i)+aincr
11570         do j=i-1,nres-1
11571           do k=1,3
11572             temp(k,j)=dc(k,nres+j)
11573           enddo
11574         enddo
11575         call chainbuild
11576         do j=i-1,nres-1
11577         ii = indmat(i-2,j)
11578 !         print *,'ii=',ii
11579         do k=1,3
11580           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11581             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11582                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11583           enddo
11584           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11585               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11586           write(iout,'(a)')
11587         enddo
11588         phi(i)=phi(i)-aincr
11589         call chainbuild
11590       enddo
11591       write (iout,'(a)') '****************** ddc/dtheta'
11592       do i=1,nres-2
11593         thet=theta(i+2)
11594         theta(i+2)=thet+aincr
11595         do j=i,nres
11596           do k=1,3
11597             temp(k,j)=dc(k,j)
11598           enddo
11599         enddo
11600         call chainbuild
11601         do j=i+1,nres-1
11602         ii = indmat(i,j)
11603 !         print *,'ii=',ii
11604         do k=1,3
11605           gg(k)=(dc(k,j)-temp(k,j))/aincr
11606           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11607                  (aincr*dabs(dcdv(k,ii))+aincr))
11608           enddo
11609           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11610                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11611         write (iout,'(a)')
11612         enddo
11613         do j=1,nres
11614           do k=1,3
11615             dc(k,j)=temp(k,j)
11616           enddo
11617         enddo
11618         theta(i+2)=thet
11619       enddo
11620       write (iout,'(a)') '******************* ddc/dphi'
11621       do i=1,nres-3
11622         phii=phi(i+3)
11623         phi(i+3)=phii+aincr
11624         do j=1,nres
11625           do k=1,3
11626             temp(k,j)=dc(k,j)
11627           enddo
11628         enddo
11629         call chainbuild
11630         do j=i+2,nres-1
11631         ii = indmat(i+1,j)
11632 !         print *,'ii=',ii
11633         do k=1,3
11634           gg(k)=(dc(k,j)-temp(k,j))/aincr
11635             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11636                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11637           enddo
11638           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11639                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11640         write (iout,'(a)')
11641         enddo
11642         do j=1,nres
11643           do k=1,3
11644             dc(k,j)=temp(k,j)
11645           enddo
11646         enddo
11647         phi(i+3)=phii
11648       enddo
11649       return
11650       end subroutine check_cartgrad
11651 !-----------------------------------------------------------------------------
11652       subroutine check_ecart
11653 ! Check the gradient of the energy in Cartesian coordinates.
11654 !     implicit real*8 (a-h,o-z)
11655 !     include 'DIMENSIONS'
11656 !     include 'COMMON.CHAIN'
11657 !     include 'COMMON.DERIV'
11658 !     include 'COMMON.IOUNITS'
11659 !     include 'COMMON.VAR'
11660 !     include 'COMMON.CONTACTS'
11661       use comm_srutu
11662 !el      integer :: icall
11663 !el      common /srutu/ icall
11664       real(kind=8),dimension(6) :: ggg
11665       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11666       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11667       real(kind=8),dimension(6,nres) :: grad_s
11668       real(kind=8),dimension(0:n_ene) :: energia,energia1
11669       integer :: uiparm(1)
11670       real(kind=8) :: urparm(1)
11671 !EL      external fdum
11672       integer :: nf,i,j,k
11673       real(kind=8) :: aincr,etot,etot1
11674       icg=1
11675       nf=0
11676       nfl=0
11677       call zerograd
11678       aincr=1.0D-5
11679       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11680       nf=0
11681       icall=0
11682       call geom_to_var(nvar,x)
11683       call etotal(energia)
11684       etot=energia(0)
11685 !el      call enerprint(energia)
11686       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11687       icall =1
11688       do i=1,nres
11689         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11690       enddo
11691       do i=1,nres
11692       do j=1,3
11693         grad_s(j,i)=gradc(j,i,icg)
11694         grad_s(j+3,i)=gradx(j,i,icg)
11695         enddo
11696       enddo
11697       call flush(iout)
11698       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11699       do i=1,nres
11700         do j=1,3
11701         xx(j)=c(j,i+nres)
11702         ddc(j)=dc(j,i)
11703         ddx(j)=dc(j,i+nres)
11704         enddo
11705       do j=1,3
11706         dc(j,i)=dc(j,i)+aincr
11707         do k=i+1,nres
11708           c(j,k)=c(j,k)+aincr
11709           c(j,k+nres)=c(j,k+nres)+aincr
11710           enddo
11711           call etotal(energia1)
11712           etot1=energia1(0)
11713         ggg(j)=(etot1-etot)/aincr
11714         dc(j,i)=ddc(j)
11715         do k=i+1,nres
11716           c(j,k)=c(j,k)-aincr
11717           c(j,k+nres)=c(j,k+nres)-aincr
11718           enddo
11719         enddo
11720       do j=1,3
11721         c(j,i+nres)=c(j,i+nres)+aincr
11722         dc(j,i+nres)=dc(j,i+nres)+aincr
11723           call etotal(energia1)
11724           etot1=energia1(0)
11725         ggg(j+3)=(etot1-etot)/aincr
11726         c(j,i+nres)=xx(j)
11727         dc(j,i+nres)=ddx(j)
11728         enddo
11729       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11730          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11731       enddo
11732       return
11733       end subroutine check_ecart
11734 #ifdef CARGRAD
11735 !-----------------------------------------------------------------------------
11736       subroutine check_ecartint
11737 ! Check the gradient of the energy in Cartesian coordinates.
11738       use io_base, only: intout
11739 !      implicit real*8 (a-h,o-z)
11740 !      include 'DIMENSIONS'
11741 !      include 'COMMON.CONTROL'
11742 !      include 'COMMON.CHAIN'
11743 !      include 'COMMON.DERIV'
11744 !      include 'COMMON.IOUNITS'
11745 !      include 'COMMON.VAR'
11746 !      include 'COMMON.CONTACTS'
11747 !      include 'COMMON.MD'
11748 !      include 'COMMON.LOCAL'
11749 !      include 'COMMON.SPLITELE'
11750       use comm_srutu
11751 !el      integer :: icall
11752 !el      common /srutu/ icall
11753       real(kind=8),dimension(6) :: ggg,ggg1
11754       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11755       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11756       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11757       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11758       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11759       real(kind=8),dimension(0:n_ene) :: energia,energia1
11760       integer :: uiparm(1)
11761       real(kind=8) :: urparm(1)
11762 !EL      external fdum
11763       integer :: i,j,k,nf
11764       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11765                    etot21,etot22
11766       r_cut=2.0d0
11767       rlambd=0.3d0
11768       icg=1
11769       nf=0
11770       nfl=0
11771       call intout
11772 !      call intcartderiv
11773 !      call checkintcartgrad
11774       call zerograd
11775       aincr=1.0D-5
11776       write(iout,*) 'Calling CHECK_ECARTINT.'
11777       nf=0
11778       icall=0
11779       write (iout,*) "Before geom_to_var"
11780       call geom_to_var(nvar,x)
11781       write (iout,*) "after geom_to_var"
11782       write (iout,*) "split_ene ",split_ene
11783       call flush(iout)
11784       if (.not.split_ene) then
11785         write(iout,*) 'Calling CHECK_ECARTINT if'
11786         call etotal(energia)
11787 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11788         etot=energia(0)
11789         write (iout,*) "etot",etot
11790         call flush(iout)
11791 !el        call enerprint(energia)
11792 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11793         call flush(iout)
11794         write (iout,*) "enter cartgrad"
11795         call flush(iout)
11796         call cartgrad
11797 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11798         write (iout,*) "exit cartgrad"
11799         call flush(iout)
11800         icall =1
11801         do i=1,nres
11802           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11803         enddo
11804         do j=1,3
11805           grad_s(j,0)=gcart(j,0)
11806         enddo
11807 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11808         do i=1,nres
11809           do j=1,3
11810             grad_s(j,i)=gcart(j,i)
11811             grad_s(j+3,i)=gxcart(j,i)
11812           enddo
11813         enddo
11814       else
11815 write(iout,*) 'Calling CHECK_ECARTIN else.'
11816 !- split gradient check
11817         call zerograd
11818         call etotal_long(energia)
11819 !el        call enerprint(energia)
11820         call flush(iout)
11821         write (iout,*) "enter cartgrad"
11822         call flush(iout)
11823         call cartgrad
11824         write (iout,*) "exit cartgrad"
11825         call flush(iout)
11826         icall =1
11827         write (iout,*) "longrange grad"
11828         do i=1,nres
11829           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11830           (gxcart(j,i),j=1,3)
11831         enddo
11832         do j=1,3
11833           grad_s(j,0)=gcart(j,0)
11834         enddo
11835         do i=1,nres
11836           do j=1,3
11837             grad_s(j,i)=gcart(j,i)
11838             grad_s(j+3,i)=gxcart(j,i)
11839           enddo
11840         enddo
11841         call zerograd
11842         call etotal_short(energia)
11843         call enerprint(energia)
11844         call flush(iout)
11845         write (iout,*) "enter cartgrad"
11846         call flush(iout)
11847         call cartgrad
11848         write (iout,*) "exit cartgrad"
11849         call flush(iout)
11850         icall =1
11851         write (iout,*) "shortrange grad"
11852         do i=1,nres
11853           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11854           (gxcart(j,i),j=1,3)
11855         enddo
11856         do j=1,3
11857           grad_s1(j,0)=gcart(j,0)
11858         enddo
11859         do i=1,nres
11860           do j=1,3
11861             grad_s1(j,i)=gcart(j,i)
11862             grad_s1(j+3,i)=gxcart(j,i)
11863           enddo
11864         enddo
11865       endif
11866       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11867 !      do i=1,nres
11868       do i=nnt,nct
11869         do j=1,3
11870           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11871           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11872         ddc(j)=c(j,i)
11873         ddx(j)=c(j,i+nres)
11874           dcnorm_safe1(j)=dc_norm(j,i-1)
11875           dcnorm_safe2(j)=dc_norm(j,i)
11876           dxnorm_safe(j)=dc_norm(j,i+nres)
11877         enddo
11878       do j=1,3
11879         c(j,i)=ddc(j)+aincr
11880           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11881           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11882           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11883           dc(j,i)=c(j,i+1)-c(j,i)
11884           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11885           call int_from_cart1(.false.)
11886           if (.not.split_ene) then
11887             call etotal(energia1)
11888             etot1=energia1(0)
11889             write (iout,*) "ij",i,j," etot1",etot1
11890           else
11891 !- split gradient
11892             call etotal_long(energia1)
11893             etot11=energia1(0)
11894             call etotal_short(energia1)
11895             etot12=energia1(0)
11896           endif
11897 !- end split gradient
11898 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11899         c(j,i)=ddc(j)-aincr
11900           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11901           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11902           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11903           dc(j,i)=c(j,i+1)-c(j,i)
11904           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11905           call int_from_cart1(.false.)
11906           if (.not.split_ene) then
11907             call etotal(energia1)
11908             etot2=energia1(0)
11909             write (iout,*) "ij",i,j," etot2",etot2
11910           ggg(j)=(etot1-etot2)/(2*aincr)
11911           else
11912 !- split gradient
11913             call etotal_long(energia1)
11914             etot21=energia1(0)
11915           ggg(j)=(etot11-etot21)/(2*aincr)
11916             call etotal_short(energia1)
11917             etot22=energia1(0)
11918           ggg1(j)=(etot12-etot22)/(2*aincr)
11919 !- end split gradient
11920 !            write (iout,*) "etot21",etot21," etot22",etot22
11921           endif
11922 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11923         c(j,i)=ddc(j)
11924           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11925           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11926           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11927           dc(j,i)=c(j,i+1)-c(j,i)
11928           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11929           dc_norm(j,i-1)=dcnorm_safe1(j)
11930           dc_norm(j,i)=dcnorm_safe2(j)
11931           dc_norm(j,i+nres)=dxnorm_safe(j)
11932         enddo
11933       do j=1,3
11934         c(j,i+nres)=ddx(j)+aincr
11935           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11936           call int_from_cart1(.false.)
11937           if (.not.split_ene) then
11938             call etotal(energia1)
11939             etot1=energia1(0)
11940           else
11941 !- split gradient
11942             call etotal_long(energia1)
11943             etot11=energia1(0)
11944             call etotal_short(energia1)
11945             etot12=energia1(0)
11946           endif
11947 !- end split gradient
11948         c(j,i+nres)=ddx(j)-aincr
11949           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11950           call int_from_cart1(.false.)
11951           if (.not.split_ene) then
11952             call etotal(energia1)
11953             etot2=energia1(0)
11954           ggg(j+3)=(etot1-etot2)/(2*aincr)
11955           else
11956 !- split gradient
11957             call etotal_long(energia1)
11958             etot21=energia1(0)
11959           ggg(j+3)=(etot11-etot21)/(2*aincr)
11960             call etotal_short(energia1)
11961             etot22=energia1(0)
11962           ggg1(j+3)=(etot12-etot22)/(2*aincr)
11963 !- end split gradient
11964           endif
11965 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11966         c(j,i+nres)=ddx(j)
11967           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11968           dc_norm(j,i+nres)=dxnorm_safe(j)
11969           call int_from_cart1(.false.)
11970         enddo
11971       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11972          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11973         if (split_ene) then
11974           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11975          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11976          k=1,6)
11977          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11978          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11979          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11980         endif
11981       enddo
11982       return
11983       end subroutine check_ecartint
11984 #else
11985 !-----------------------------------------------------------------------------
11986       subroutine check_ecartint
11987 ! Check the gradient of the energy in Cartesian coordinates.
11988       use io_base, only: intout
11989 !      implicit real*8 (a-h,o-z)
11990 !      include 'DIMENSIONS'
11991 !      include 'COMMON.CONTROL'
11992 !      include 'COMMON.CHAIN'
11993 !      include 'COMMON.DERIV'
11994 !      include 'COMMON.IOUNITS'
11995 !      include 'COMMON.VAR'
11996 !      include 'COMMON.CONTACTS'
11997 !      include 'COMMON.MD'
11998 !      include 'COMMON.LOCAL'
11999 !      include 'COMMON.SPLITELE'
12000       use comm_srutu
12001 !el      integer :: icall
12002 !el      common /srutu/ icall
12003       real(kind=8),dimension(6) :: ggg,ggg1
12004       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12005       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12006       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12007       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12008       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12009       real(kind=8),dimension(0:n_ene) :: energia,energia1
12010       integer :: uiparm(1)
12011       real(kind=8) :: urparm(1)
12012 !EL      external fdum
12013       integer :: i,j,k,nf
12014       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12015                    etot21,etot22
12016       r_cut=2.0d0
12017       rlambd=0.3d0
12018       icg=1
12019       nf=0
12020       nfl=0
12021       call intout
12022 !      call intcartderiv
12023 !      call checkintcartgrad
12024       call zerograd
12025       aincr=2.0D-5
12026       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12027       nf=0
12028       icall=0
12029       call geom_to_var(nvar,x)
12030       if (.not.split_ene) then
12031         call etotal(energia)
12032         etot=energia(0)
12033 !el        call enerprint(energia)
12034         call flush(iout)
12035         write (iout,*) "enter cartgrad"
12036         call flush(iout)
12037         call cartgrad
12038         write (iout,*) "exit cartgrad"
12039         call flush(iout)
12040         icall =1
12041         do i=1,nres
12042           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12043         enddo
12044         do j=1,3
12045           grad_s(j,0)=gcart(j,0)
12046         enddo
12047         do i=1,nres
12048           do j=1,3
12049             grad_s(j,i)=gcart(j,i)
12050 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12051             grad_s(j+3,i)=gxcart(j,i)
12052           enddo
12053         enddo
12054       else
12055 !- split gradient check
12056         call zerograd
12057         call etotal_long(energia)
12058 !el        call enerprint(energia)
12059         call flush(iout)
12060         write (iout,*) "enter cartgrad"
12061         call flush(iout)
12062         call cartgrad
12063         write (iout,*) "exit cartgrad"
12064         call flush(iout)
12065         icall =1
12066         write (iout,*) "longrange grad"
12067         do i=1,nres
12068           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12069           (gxcart(j,i),j=1,3)
12070         enddo
12071         do j=1,3
12072           grad_s(j,0)=gcart(j,0)
12073         enddo
12074         do i=1,nres
12075           do j=1,3
12076             grad_s(j,i)=gcart(j,i)
12077             grad_s(j+3,i)=gxcart(j,i)
12078           enddo
12079         enddo
12080         call zerograd
12081         call etotal_short(energia)
12082 !el        call enerprint(energia)
12083         call flush(iout)
12084         write (iout,*) "enter cartgrad"
12085         call flush(iout)
12086         call cartgrad
12087         write (iout,*) "exit cartgrad"
12088         call flush(iout)
12089         icall =1
12090         write (iout,*) "shortrange grad"
12091         do i=1,nres
12092           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12093           (gxcart(j,i),j=1,3)
12094         enddo
12095         do j=1,3
12096           grad_s1(j,0)=gcart(j,0)
12097         enddo
12098         do i=1,nres
12099           do j=1,3
12100             grad_s1(j,i)=gcart(j,i)
12101             grad_s1(j+3,i)=gxcart(j,i)
12102           enddo
12103         enddo
12104       endif
12105       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12106       do i=0,nres
12107         do j=1,3
12108         xx(j)=c(j,i+nres)
12109         ddc(j)=dc(j,i)
12110         ddx(j)=dc(j,i+nres)
12111           do k=1,3
12112             dcnorm_safe(k)=dc_norm(k,i)
12113             dxnorm_safe(k)=dc_norm(k,i+nres)
12114           enddo
12115         enddo
12116       do j=1,3
12117         dc(j,i)=ddc(j)+aincr
12118           call chainbuild_cart
12119 #ifdef MPI
12120 ! Broadcast the order to compute internal coordinates to the slaves.
12121 !          if (nfgtasks.gt.1)
12122 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12123 #endif
12124 !          call int_from_cart1(.false.)
12125           if (.not.split_ene) then
12126             call etotal(energia1)
12127             etot1=energia1(0)
12128 !            call enerprint(energia1)
12129           else
12130 !- split gradient
12131             call etotal_long(energia1)
12132             etot11=energia1(0)
12133             call etotal_short(energia1)
12134             etot12=energia1(0)
12135 !            write (iout,*) "etot11",etot11," etot12",etot12
12136           endif
12137 !- end split gradient
12138 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12139         dc(j,i)=ddc(j)-aincr
12140           call chainbuild_cart
12141 !          call int_from_cart1(.false.)
12142           if (.not.split_ene) then
12143             call etotal(energia1)
12144             etot2=energia1(0)
12145           ggg(j)=(etot1-etot2)/(2*aincr)
12146           else
12147 !- split gradient
12148             call etotal_long(energia1)
12149             etot21=energia1(0)
12150           ggg(j)=(etot11-etot21)/(2*aincr)
12151             call etotal_short(energia1)
12152             etot22=energia1(0)
12153           ggg1(j)=(etot12-etot22)/(2*aincr)
12154 !- end split gradient
12155 !            write (iout,*) "etot21",etot21," etot22",etot22
12156           endif
12157 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12158         dc(j,i)=ddc(j)
12159           call chainbuild_cart
12160         enddo
12161       do j=1,3
12162         dc(j,i+nres)=ddx(j)+aincr
12163           call chainbuild_cart
12164 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12165 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12166 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12167 !          write (iout,*) "dxnormnorm",dsqrt(
12168 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12169 !          write (iout,*) "dxnormnormsafe",dsqrt(
12170 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12171 !          write (iout,*)
12172           if (.not.split_ene) then
12173             call etotal(energia1)
12174             etot1=energia1(0)
12175           else
12176 !- split gradient
12177             call etotal_long(energia1)
12178             etot11=energia1(0)
12179             call etotal_short(energia1)
12180             etot12=energia1(0)
12181           endif
12182 !- end split gradient
12183 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12184         dc(j,i+nres)=ddx(j)-aincr
12185           call chainbuild_cart
12186 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12187 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12188 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12189 !          write (iout,*)
12190 !          write (iout,*) "dxnormnorm",dsqrt(
12191 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12192 !          write (iout,*) "dxnormnormsafe",dsqrt(
12193 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12194           if (.not.split_ene) then
12195             call etotal(energia1)
12196             etot2=energia1(0)
12197           ggg(j+3)=(etot1-etot2)/(2*aincr)
12198           else
12199 !- split gradient
12200             call etotal_long(energia1)
12201             etot21=energia1(0)
12202           ggg(j+3)=(etot11-etot21)/(2*aincr)
12203             call etotal_short(energia1)
12204             etot22=energia1(0)
12205           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12206 !- end split gradient
12207           endif
12208 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12209         dc(j,i+nres)=ddx(j)
12210           call chainbuild_cart
12211         enddo
12212       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12213          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12214         if (split_ene) then
12215           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12216          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12217          k=1,6)
12218          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12219          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12220          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12221         endif
12222       enddo
12223       return
12224       end subroutine check_ecartint
12225 #endif
12226 !-----------------------------------------------------------------------------
12227       subroutine check_eint
12228 ! Check the gradient of energy in internal coordinates.
12229 !      implicit real*8 (a-h,o-z)
12230 !      include 'DIMENSIONS'
12231 !      include 'COMMON.CHAIN'
12232 !      include 'COMMON.DERIV'
12233 !      include 'COMMON.IOUNITS'
12234 !      include 'COMMON.VAR'
12235 !      include 'COMMON.GEO'
12236       use comm_srutu
12237 !el      integer :: icall
12238 !el      common /srutu/ icall
12239       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12240       integer :: uiparm(1)
12241       real(kind=8) :: urparm(1)
12242       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12243       character(len=6) :: key
12244 !EL      external fdum
12245       integer :: i,ii,nf
12246       real(kind=8) :: xi,aincr,etot,etot1,etot2
12247       call zerograd
12248       aincr=1.0D-7
12249       print '(a)','Calling CHECK_INT.'
12250       nf=0
12251       nfl=0
12252       icg=1
12253       call geom_to_var(nvar,x)
12254       call var_to_geom(nvar,x)
12255       call chainbuild
12256       icall=1
12257 !      print *,'ICG=',ICG
12258       call etotal(energia)
12259       etot = energia(0)
12260 !el      call enerprint(energia)
12261 !      print *,'ICG=',ICG
12262 #ifdef MPL
12263       if (MyID.ne.BossID) then
12264         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12265         nf=x(nvar+1)
12266         nfl=x(nvar+2)
12267         icg=x(nvar+3)
12268       endif
12269 #endif
12270       nf=1
12271       nfl=3
12272 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12273       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12274 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12275       icall=1
12276       do i=1,nvar
12277         xi=x(i)
12278         x(i)=xi-0.5D0*aincr
12279         call var_to_geom(nvar,x)
12280         call chainbuild
12281         call etotal(energia1)
12282         etot1=energia1(0)
12283         x(i)=xi+0.5D0*aincr
12284         call var_to_geom(nvar,x)
12285         call chainbuild
12286         call etotal(energia2)
12287         etot2=energia2(0)
12288         gg(i)=(etot2-etot1)/aincr
12289         write (iout,*) i,etot1,etot2
12290         x(i)=xi
12291       enddo
12292       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12293           '     RelDiff*100% '
12294       do i=1,nvar
12295         if (i.le.nphi) then
12296           ii=i
12297           key = ' phi'
12298         else if (i.le.nphi+ntheta) then
12299           ii=i-nphi
12300           key=' theta'
12301         else if (i.le.nphi+ntheta+nside) then
12302            ii=i-(nphi+ntheta)
12303            key=' alpha'
12304         else
12305            ii=i-(nphi+ntheta+nside)
12306            key=' omega'
12307         endif
12308         write (iout,'(i3,a,i3,3(1pd16.6))') &
12309        i,key,ii,gg(i),gana(i),&
12310        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12311       enddo
12312       return
12313       end subroutine check_eint
12314 !-----------------------------------------------------------------------------
12315 ! econstr_local.F
12316 !-----------------------------------------------------------------------------
12317       subroutine Econstr_back
12318 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12319 !      implicit real*8 (a-h,o-z)
12320 !      include 'DIMENSIONS'
12321 !      include 'COMMON.CONTROL'
12322 !      include 'COMMON.VAR'
12323 !      include 'COMMON.MD'
12324       use MD_data
12325 !#ifndef LANG0
12326 !      include 'COMMON.LANGEVIN'
12327 !#else
12328 !      include 'COMMON.LANGEVIN.lang0'
12329 !#endif
12330 !      include 'COMMON.CHAIN'
12331 !      include 'COMMON.DERIV'
12332 !      include 'COMMON.GEO'
12333 !      include 'COMMON.LOCAL'
12334 !      include 'COMMON.INTERACT'
12335 !      include 'COMMON.IOUNITS'
12336 !      include 'COMMON.NAMES'
12337 !      include 'COMMON.TIME1'
12338       integer :: i,j,ii,k
12339       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12340
12341       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12342       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12343       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12344
12345       Uconst_back=0.0d0
12346       do i=1,nres
12347         dutheta(i)=0.0d0
12348         dugamma(i)=0.0d0
12349         do j=1,3
12350           duscdiff(j,i)=0.0d0
12351           duscdiffx(j,i)=0.0d0
12352         enddo
12353       enddo
12354       do i=1,nfrag_back
12355         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12356 !
12357 ! Deviations from theta angles
12358 !
12359         utheta_i=0.0d0
12360         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12361           dtheta_i=theta(j)-thetaref(j)
12362           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12363           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12364         enddo
12365         utheta(i)=utheta_i/(ii-1)
12366 !
12367 ! Deviations from gamma angles
12368 !
12369         ugamma_i=0.0d0
12370         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12371           dgamma_i=pinorm(phi(j)-phiref(j))
12372 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12373           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12374           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12375 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12376         enddo
12377         ugamma(i)=ugamma_i/(ii-2)
12378 !
12379 ! Deviations from local SC geometry
12380 !
12381         uscdiff(i)=0.0d0
12382         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12383           dxx=xxtab(j)-xxref(j)
12384           dyy=yytab(j)-yyref(j)
12385           dzz=zztab(j)-zzref(j)
12386           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12387           do k=1,3
12388             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12389              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12390              (ii-1)
12391             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12392              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12393              (ii-1)
12394             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12395            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12396             /(ii-1)
12397           enddo
12398 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12399 !     &      xxref(j),yyref(j),zzref(j)
12400         enddo
12401         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12402 !        write (iout,*) i," uscdiff",uscdiff(i)
12403 !
12404 ! Put together deviations from local geometry
12405 !
12406         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12407           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12408 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12409 !     &   " uconst_back",uconst_back
12410         utheta(i)=dsqrt(utheta(i))
12411         ugamma(i)=dsqrt(ugamma(i))
12412         uscdiff(i)=dsqrt(uscdiff(i))
12413       enddo
12414       return
12415       end subroutine Econstr_back
12416 !-----------------------------------------------------------------------------
12417 ! energy_p_new-sep_barrier.F
12418 !-----------------------------------------------------------------------------
12419       real(kind=8) function sscale(r)
12420 !      include "COMMON.SPLITELE"
12421       real(kind=8) :: r,gamm
12422       if(r.lt.r_cut-rlamb) then
12423         sscale=1.0d0
12424       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12425         gamm=(r-(r_cut-rlamb))/rlamb
12426         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12427       else
12428         sscale=0d0
12429       endif
12430       return
12431       end function sscale
12432       real(kind=8) function sscale_grad(r)
12433 !      include "COMMON.SPLITELE"
12434       real(kind=8) :: r,gamm
12435       if(r.lt.r_cut-rlamb) then
12436         sscale_grad=0.0d0
12437       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12438         gamm=(r-(r_cut-rlamb))/rlamb
12439         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12440       else
12441         sscale_grad=0d0
12442       endif
12443       return
12444       end function sscale_grad
12445
12446 !!!!!!!!!! PBCSCALE
12447       real(kind=8) function sscale_ele(r)
12448 !      include "COMMON.SPLITELE"
12449       real(kind=8) :: r,gamm
12450       if(r.lt.r_cut_ele-rlamb_ele) then
12451         sscale_ele=1.0d0
12452       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12453         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12454         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12455       else
12456         sscale_ele=0d0
12457       endif
12458       return
12459       end function sscale_ele
12460
12461       real(kind=8)  function sscagrad_ele(r)
12462       real(kind=8) :: r,gamm
12463 !      include "COMMON.SPLITELE"
12464       if(r.lt.r_cut_ele-rlamb_ele) then
12465         sscagrad_ele=0.0d0
12466       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12467         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12468         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12469       else
12470         sscagrad_ele=0.0d0
12471       endif
12472       return
12473       end function sscagrad_ele
12474       real(kind=8) function sscalelip(r)
12475       real(kind=8) r,gamm
12476         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12477       return
12478       end function sscalelip
12479 !C-----------------------------------------------------------------------
12480       real(kind=8) function sscagradlip(r)
12481       real(kind=8) r,gamm
12482         sscagradlip=r*(6.0d0*r-6.0d0)
12483       return
12484       end function sscagradlip
12485
12486 !!!!!!!!!!!!!!!
12487 !-----------------------------------------------------------------------------
12488       subroutine elj_long(evdw)
12489 !
12490 ! This subroutine calculates the interaction energy of nonbonded side chains
12491 ! assuming the LJ potential of interaction.
12492 !
12493 !      implicit real*8 (a-h,o-z)
12494 !      include 'DIMENSIONS'
12495 !      include 'COMMON.GEO'
12496 !      include 'COMMON.VAR'
12497 !      include 'COMMON.LOCAL'
12498 !      include 'COMMON.CHAIN'
12499 !      include 'COMMON.DERIV'
12500 !      include 'COMMON.INTERACT'
12501 !      include 'COMMON.TORSION'
12502 !      include 'COMMON.SBRIDGE'
12503 !      include 'COMMON.NAMES'
12504 !      include 'COMMON.IOUNITS'
12505 !      include 'COMMON.CONTACTS'
12506       real(kind=8),parameter :: accur=1.0d-10
12507       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12508 !el local variables
12509       integer :: i,iint,j,k,itypi,itypi1,itypj
12510       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12511       real(kind=8) :: e1,e2,evdwij,evdw
12512 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12513       evdw=0.0D0
12514       do i=iatsc_s,iatsc_e
12515         itypi=itype(i,1)
12516         if (itypi.eq.ntyp1) cycle
12517         itypi1=itype(i+1,1)
12518         xi=c(1,nres+i)
12519         yi=c(2,nres+i)
12520         zi=c(3,nres+i)
12521 !
12522 ! Calculate SC interaction energy.
12523 !
12524         do iint=1,nint_gr(i)
12525 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12526 !d   &                  'iend=',iend(i,iint)
12527           do j=istart(i,iint),iend(i,iint)
12528             itypj=itype(j,1)
12529             if (itypj.eq.ntyp1) cycle
12530             xj=c(1,nres+j)-xi
12531             yj=c(2,nres+j)-yi
12532             zj=c(3,nres+j)-zi
12533             rij=xj*xj+yj*yj+zj*zj
12534             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12535             if (sss.lt.1.0d0) then
12536               rrij=1.0D0/rij
12537               eps0ij=eps(itypi,itypj)
12538               fac=rrij**expon2
12539               e1=fac*fac*aa_aq(itypi,itypj)
12540               e2=fac*bb_aq(itypi,itypj)
12541               evdwij=e1+e2
12542               evdw=evdw+(1.0d0-sss)*evdwij
12543 !
12544 ! Calculate the components of the gradient in DC and X
12545 !
12546               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12547               gg(1)=xj*fac
12548               gg(2)=yj*fac
12549               gg(3)=zj*fac
12550               do k=1,3
12551                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12552                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12553                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12554                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12555               enddo
12556             endif
12557           enddo      ! j
12558         enddo        ! iint
12559       enddo          ! i
12560       do i=1,nct
12561         do j=1,3
12562           gvdwc(j,i)=expon*gvdwc(j,i)
12563           gvdwx(j,i)=expon*gvdwx(j,i)
12564         enddo
12565       enddo
12566 !******************************************************************************
12567 !
12568 !                              N O T E !!!
12569 !
12570 ! To save time, the factor of EXPON has been extracted from ALL components
12571 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12572 ! use!
12573 !
12574 !******************************************************************************
12575       return
12576       end subroutine elj_long
12577 !-----------------------------------------------------------------------------
12578       subroutine elj_short(evdw)
12579 !
12580 ! This subroutine calculates the interaction energy of nonbonded side chains
12581 ! assuming the LJ potential of interaction.
12582 !
12583 !      implicit real*8 (a-h,o-z)
12584 !      include 'DIMENSIONS'
12585 !      include 'COMMON.GEO'
12586 !      include 'COMMON.VAR'
12587 !      include 'COMMON.LOCAL'
12588 !      include 'COMMON.CHAIN'
12589 !      include 'COMMON.DERIV'
12590 !      include 'COMMON.INTERACT'
12591 !      include 'COMMON.TORSION'
12592 !      include 'COMMON.SBRIDGE'
12593 !      include 'COMMON.NAMES'
12594 !      include 'COMMON.IOUNITS'
12595 !      include 'COMMON.CONTACTS'
12596       real(kind=8),parameter :: accur=1.0d-10
12597       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12598 !el local variables
12599       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12600       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12601       real(kind=8) :: e1,e2,evdwij,evdw
12602 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12603       evdw=0.0D0
12604       do i=iatsc_s,iatsc_e
12605         itypi=itype(i,1)
12606         if (itypi.eq.ntyp1) cycle
12607         itypi1=itype(i+1,1)
12608         xi=c(1,nres+i)
12609         yi=c(2,nres+i)
12610         zi=c(3,nres+i)
12611 ! Change 12/1/95
12612         num_conti=0
12613 !
12614 ! Calculate SC interaction energy.
12615 !
12616         do iint=1,nint_gr(i)
12617 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12618 !d   &                  'iend=',iend(i,iint)
12619           do j=istart(i,iint),iend(i,iint)
12620             itypj=itype(j,1)
12621             if (itypj.eq.ntyp1) cycle
12622             xj=c(1,nres+j)-xi
12623             yj=c(2,nres+j)-yi
12624             zj=c(3,nres+j)-zi
12625 ! Change 12/1/95 to calculate four-body interactions
12626             rij=xj*xj+yj*yj+zj*zj
12627             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12628             if (sss.gt.0.0d0) then
12629               rrij=1.0D0/rij
12630               eps0ij=eps(itypi,itypj)
12631               fac=rrij**expon2
12632               e1=fac*fac*aa_aq(itypi,itypj)
12633               e2=fac*bb_aq(itypi,itypj)
12634               evdwij=e1+e2
12635               evdw=evdw+sss*evdwij
12636 !
12637 ! Calculate the components of the gradient in DC and X
12638 !
12639               fac=-rrij*(e1+evdwij)*sss
12640               gg(1)=xj*fac
12641               gg(2)=yj*fac
12642               gg(3)=zj*fac
12643               do k=1,3
12644                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12645                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12646                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12647                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12648               enddo
12649             endif
12650           enddo      ! j
12651         enddo        ! iint
12652       enddo          ! i
12653       do i=1,nct
12654         do j=1,3
12655           gvdwc(j,i)=expon*gvdwc(j,i)
12656           gvdwx(j,i)=expon*gvdwx(j,i)
12657         enddo
12658       enddo
12659 !******************************************************************************
12660 !
12661 !                              N O T E !!!
12662 !
12663 ! To save time, the factor of EXPON has been extracted from ALL components
12664 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12665 ! use!
12666 !
12667 !******************************************************************************
12668       return
12669       end subroutine elj_short
12670 !-----------------------------------------------------------------------------
12671       subroutine eljk_long(evdw)
12672 !
12673 ! This subroutine calculates the interaction energy of nonbonded side chains
12674 ! assuming the LJK potential of interaction.
12675 !
12676 !      implicit real*8 (a-h,o-z)
12677 !      include 'DIMENSIONS'
12678 !      include 'COMMON.GEO'
12679 !      include 'COMMON.VAR'
12680 !      include 'COMMON.LOCAL'
12681 !      include 'COMMON.CHAIN'
12682 !      include 'COMMON.DERIV'
12683 !      include 'COMMON.INTERACT'
12684 !      include 'COMMON.IOUNITS'
12685 !      include 'COMMON.NAMES'
12686       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12687       logical :: scheck
12688 !el local variables
12689       integer :: i,iint,j,k,itypi,itypi1,itypj
12690       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12691                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12692 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12693       evdw=0.0D0
12694       do i=iatsc_s,iatsc_e
12695         itypi=itype(i,1)
12696         if (itypi.eq.ntyp1) cycle
12697         itypi1=itype(i+1,1)
12698         xi=c(1,nres+i)
12699         yi=c(2,nres+i)
12700         zi=c(3,nres+i)
12701 !
12702 ! Calculate SC interaction energy.
12703 !
12704         do iint=1,nint_gr(i)
12705           do j=istart(i,iint),iend(i,iint)
12706             itypj=itype(j,1)
12707             if (itypj.eq.ntyp1) cycle
12708             xj=c(1,nres+j)-xi
12709             yj=c(2,nres+j)-yi
12710             zj=c(3,nres+j)-zi
12711             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12712             fac_augm=rrij**expon
12713             e_augm=augm(itypi,itypj)*fac_augm
12714             r_inv_ij=dsqrt(rrij)
12715             rij=1.0D0/r_inv_ij
12716             sss=sscale(rij/sigma(itypi,itypj))
12717             if (sss.lt.1.0d0) then
12718               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12719               fac=r_shift_inv**expon
12720               e1=fac*fac*aa_aq(itypi,itypj)
12721               e2=fac*bb_aq(itypi,itypj)
12722               evdwij=e_augm+e1+e2
12723 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12724 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12725 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12726 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12727 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12728 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12729 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12730               evdw=evdw+(1.0d0-sss)*evdwij
12731 !
12732 ! Calculate the components of the gradient in DC and X
12733 !
12734               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12735               fac=fac*(1.0d0-sss)
12736               gg(1)=xj*fac
12737               gg(2)=yj*fac
12738               gg(3)=zj*fac
12739               do k=1,3
12740                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12741                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12742                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12743                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12744               enddo
12745             endif
12746           enddo      ! j
12747         enddo        ! iint
12748       enddo          ! i
12749       do i=1,nct
12750         do j=1,3
12751           gvdwc(j,i)=expon*gvdwc(j,i)
12752           gvdwx(j,i)=expon*gvdwx(j,i)
12753         enddo
12754       enddo
12755       return
12756       end subroutine eljk_long
12757 !-----------------------------------------------------------------------------
12758       subroutine eljk_short(evdw)
12759 !
12760 ! This subroutine calculates the interaction energy of nonbonded side chains
12761 ! assuming the LJK potential of interaction.
12762 !
12763 !      implicit real*8 (a-h,o-z)
12764 !      include 'DIMENSIONS'
12765 !      include 'COMMON.GEO'
12766 !      include 'COMMON.VAR'
12767 !      include 'COMMON.LOCAL'
12768 !      include 'COMMON.CHAIN'
12769 !      include 'COMMON.DERIV'
12770 !      include 'COMMON.INTERACT'
12771 !      include 'COMMON.IOUNITS'
12772 !      include 'COMMON.NAMES'
12773       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12774       logical :: scheck
12775 !el local variables
12776       integer :: i,iint,j,k,itypi,itypi1,itypj
12777       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12778                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12779 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12780       evdw=0.0D0
12781       do i=iatsc_s,iatsc_e
12782         itypi=itype(i,1)
12783         if (itypi.eq.ntyp1) cycle
12784         itypi1=itype(i+1,1)
12785         xi=c(1,nres+i)
12786         yi=c(2,nres+i)
12787         zi=c(3,nres+i)
12788 !
12789 ! Calculate SC interaction energy.
12790 !
12791         do iint=1,nint_gr(i)
12792           do j=istart(i,iint),iend(i,iint)
12793             itypj=itype(j,1)
12794             if (itypj.eq.ntyp1) cycle
12795             xj=c(1,nres+j)-xi
12796             yj=c(2,nres+j)-yi
12797             zj=c(3,nres+j)-zi
12798             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12799             fac_augm=rrij**expon
12800             e_augm=augm(itypi,itypj)*fac_augm
12801             r_inv_ij=dsqrt(rrij)
12802             rij=1.0D0/r_inv_ij
12803             sss=sscale(rij/sigma(itypi,itypj))
12804             if (sss.gt.0.0d0) then
12805               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12806               fac=r_shift_inv**expon
12807               e1=fac*fac*aa_aq(itypi,itypj)
12808               e2=fac*bb_aq(itypi,itypj)
12809               evdwij=e_augm+e1+e2
12810 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12811 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12812 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12813 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12814 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12815 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12816 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12817               evdw=evdw+sss*evdwij
12818 !
12819 ! Calculate the components of the gradient in DC and X
12820 !
12821               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12822               fac=fac*sss
12823               gg(1)=xj*fac
12824               gg(2)=yj*fac
12825               gg(3)=zj*fac
12826               do k=1,3
12827                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12828                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12829                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12830                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12831               enddo
12832             endif
12833           enddo      ! j
12834         enddo        ! iint
12835       enddo          ! i
12836       do i=1,nct
12837         do j=1,3
12838           gvdwc(j,i)=expon*gvdwc(j,i)
12839           gvdwx(j,i)=expon*gvdwx(j,i)
12840         enddo
12841       enddo
12842       return
12843       end subroutine eljk_short
12844 !-----------------------------------------------------------------------------
12845       subroutine ebp_long(evdw)
12846 !
12847 ! This subroutine calculates the interaction energy of nonbonded side chains
12848 ! assuming the Berne-Pechukas potential of interaction.
12849 !
12850       use calc_data
12851 !      implicit real*8 (a-h,o-z)
12852 !      include 'DIMENSIONS'
12853 !      include 'COMMON.GEO'
12854 !      include 'COMMON.VAR'
12855 !      include 'COMMON.LOCAL'
12856 !      include 'COMMON.CHAIN'
12857 !      include 'COMMON.DERIV'
12858 !      include 'COMMON.NAMES'
12859 !      include 'COMMON.INTERACT'
12860 !      include 'COMMON.IOUNITS'
12861 !      include 'COMMON.CALC'
12862       use comm_srutu
12863 !el      integer :: icall
12864 !el      common /srutu/ icall
12865 !     double precision rrsave(maxdim)
12866       logical :: lprn
12867 !el local variables
12868       integer :: iint,itypi,itypi1,itypj
12869       real(kind=8) :: rrij,xi,yi,zi,fac
12870       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12871       evdw=0.0D0
12872 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12873       evdw=0.0D0
12874 !     if (icall.eq.0) then
12875 !       lprn=.true.
12876 !     else
12877         lprn=.false.
12878 !     endif
12879 !el      ind=0
12880       do i=iatsc_s,iatsc_e
12881         itypi=itype(i,1)
12882         if (itypi.eq.ntyp1) cycle
12883         itypi1=itype(i+1,1)
12884         xi=c(1,nres+i)
12885         yi=c(2,nres+i)
12886         zi=c(3,nres+i)
12887         dxi=dc_norm(1,nres+i)
12888         dyi=dc_norm(2,nres+i)
12889         dzi=dc_norm(3,nres+i)
12890 !        dsci_inv=dsc_inv(itypi)
12891         dsci_inv=vbld_inv(i+nres)
12892 !
12893 ! Calculate SC interaction energy.
12894 !
12895         do iint=1,nint_gr(i)
12896           do j=istart(i,iint),iend(i,iint)
12897 !el            ind=ind+1
12898             itypj=itype(j,1)
12899             if (itypj.eq.ntyp1) cycle
12900 !            dscj_inv=dsc_inv(itypj)
12901             dscj_inv=vbld_inv(j+nres)
12902             chi1=chi(itypi,itypj)
12903             chi2=chi(itypj,itypi)
12904             chi12=chi1*chi2
12905             chip1=chip(itypi)
12906             chip2=chip(itypj)
12907             chip12=chip1*chip2
12908             alf1=alp(itypi)
12909             alf2=alp(itypj)
12910             alf12=0.5D0*(alf1+alf2)
12911             xj=c(1,nres+j)-xi
12912             yj=c(2,nres+j)-yi
12913             zj=c(3,nres+j)-zi
12914             dxj=dc_norm(1,nres+j)
12915             dyj=dc_norm(2,nres+j)
12916             dzj=dc_norm(3,nres+j)
12917             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12918             rij=dsqrt(rrij)
12919             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12920
12921             if (sss.lt.1.0d0) then
12922
12923 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12924               call sc_angular
12925 ! Calculate whole angle-dependent part of epsilon and contributions
12926 ! to its derivatives
12927               fac=(rrij*sigsq)**expon2
12928               e1=fac*fac*aa_aq(itypi,itypj)
12929               e2=fac*bb_aq(itypi,itypj)
12930               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12931               eps2der=evdwij*eps3rt
12932               eps3der=evdwij*eps2rt
12933               evdwij=evdwij*eps2rt*eps3rt
12934               evdw=evdw+evdwij*(1.0d0-sss)
12935               if (lprn) then
12936               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12937               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12938 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12939 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12940 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12941 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12942 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12943 !d     &          evdwij
12944               endif
12945 ! Calculate gradient components.
12946               e1=e1*eps1*eps2rt**2*eps3rt**2
12947               fac=-expon*(e1+evdwij)
12948               sigder=fac/sigsq
12949               fac=rrij*fac
12950 ! Calculate radial part of the gradient
12951               gg(1)=xj*fac
12952               gg(2)=yj*fac
12953               gg(3)=zj*fac
12954 ! Calculate the angular part of the gradient and sum add the contributions
12955 ! to the appropriate components of the Cartesian gradient.
12956               call sc_grad_scale(1.0d0-sss)
12957             endif
12958           enddo      ! j
12959         enddo        ! iint
12960       enddo          ! i
12961 !     stop
12962       return
12963       end subroutine ebp_long
12964 !-----------------------------------------------------------------------------
12965       subroutine ebp_short(evdw)
12966 !
12967 ! This subroutine calculates the interaction energy of nonbonded side chains
12968 ! assuming the Berne-Pechukas potential of interaction.
12969 !
12970       use calc_data
12971 !      implicit real*8 (a-h,o-z)
12972 !      include 'DIMENSIONS'
12973 !      include 'COMMON.GEO'
12974 !      include 'COMMON.VAR'
12975 !      include 'COMMON.LOCAL'
12976 !      include 'COMMON.CHAIN'
12977 !      include 'COMMON.DERIV'
12978 !      include 'COMMON.NAMES'
12979 !      include 'COMMON.INTERACT'
12980 !      include 'COMMON.IOUNITS'
12981 !      include 'COMMON.CALC'
12982       use comm_srutu
12983 !el      integer :: icall
12984 !el      common /srutu/ icall
12985 !     double precision rrsave(maxdim)
12986       logical :: lprn
12987 !el local variables
12988       integer :: iint,itypi,itypi1,itypj
12989       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12990       real(kind=8) :: sss,e1,e2,evdw
12991       evdw=0.0D0
12992 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12993       evdw=0.0D0
12994 !     if (icall.eq.0) then
12995 !       lprn=.true.
12996 !     else
12997         lprn=.false.
12998 !     endif
12999 !el      ind=0
13000       do i=iatsc_s,iatsc_e
13001         itypi=itype(i,1)
13002         if (itypi.eq.ntyp1) cycle
13003         itypi1=itype(i+1,1)
13004         xi=c(1,nres+i)
13005         yi=c(2,nres+i)
13006         zi=c(3,nres+i)
13007         dxi=dc_norm(1,nres+i)
13008         dyi=dc_norm(2,nres+i)
13009         dzi=dc_norm(3,nres+i)
13010 !        dsci_inv=dsc_inv(itypi)
13011         dsci_inv=vbld_inv(i+nres)
13012 !
13013 ! Calculate SC interaction energy.
13014 !
13015         do iint=1,nint_gr(i)
13016           do j=istart(i,iint),iend(i,iint)
13017 !el            ind=ind+1
13018             itypj=itype(j,1)
13019             if (itypj.eq.ntyp1) cycle
13020 !            dscj_inv=dsc_inv(itypj)
13021             dscj_inv=vbld_inv(j+nres)
13022             chi1=chi(itypi,itypj)
13023             chi2=chi(itypj,itypi)
13024             chi12=chi1*chi2
13025             chip1=chip(itypi)
13026             chip2=chip(itypj)
13027             chip12=chip1*chip2
13028             alf1=alp(itypi)
13029             alf2=alp(itypj)
13030             alf12=0.5D0*(alf1+alf2)
13031             xj=c(1,nres+j)-xi
13032             yj=c(2,nres+j)-yi
13033             zj=c(3,nres+j)-zi
13034             dxj=dc_norm(1,nres+j)
13035             dyj=dc_norm(2,nres+j)
13036             dzj=dc_norm(3,nres+j)
13037             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13038             rij=dsqrt(rrij)
13039             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13040
13041             if (sss.gt.0.0d0) then
13042
13043 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13044               call sc_angular
13045 ! Calculate whole angle-dependent part of epsilon and contributions
13046 ! to its derivatives
13047               fac=(rrij*sigsq)**expon2
13048               e1=fac*fac*aa_aq(itypi,itypj)
13049               e2=fac*bb_aq(itypi,itypj)
13050               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13051               eps2der=evdwij*eps3rt
13052               eps3der=evdwij*eps2rt
13053               evdwij=evdwij*eps2rt*eps3rt
13054               evdw=evdw+evdwij*sss
13055               if (lprn) then
13056               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13057               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13058 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13059 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13060 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13061 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13062 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13063 !d     &          evdwij
13064               endif
13065 ! Calculate gradient components.
13066               e1=e1*eps1*eps2rt**2*eps3rt**2
13067               fac=-expon*(e1+evdwij)
13068               sigder=fac/sigsq
13069               fac=rrij*fac
13070 ! Calculate radial part of the gradient
13071               gg(1)=xj*fac
13072               gg(2)=yj*fac
13073               gg(3)=zj*fac
13074 ! Calculate the angular part of the gradient and sum add the contributions
13075 ! to the appropriate components of the Cartesian gradient.
13076               call sc_grad_scale(sss)
13077             endif
13078           enddo      ! j
13079         enddo        ! iint
13080       enddo          ! i
13081 !     stop
13082       return
13083       end subroutine ebp_short
13084 !-----------------------------------------------------------------------------
13085       subroutine egb_long(evdw)
13086 !
13087 ! This subroutine calculates the interaction energy of nonbonded side chains
13088 ! assuming the Gay-Berne potential of interaction.
13089 !
13090       use calc_data
13091 !      implicit real*8 (a-h,o-z)
13092 !      include 'DIMENSIONS'
13093 !      include 'COMMON.GEO'
13094 !      include 'COMMON.VAR'
13095 !      include 'COMMON.LOCAL'
13096 !      include 'COMMON.CHAIN'
13097 !      include 'COMMON.DERIV'
13098 !      include 'COMMON.NAMES'
13099 !      include 'COMMON.INTERACT'
13100 !      include 'COMMON.IOUNITS'
13101 !      include 'COMMON.CALC'
13102 !      include 'COMMON.CONTROL'
13103       logical :: lprn
13104 !el local variables
13105       integer :: iint,itypi,itypi1,itypj,subchap
13106       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13107       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13108       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13109                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13110                     ssgradlipi,ssgradlipj
13111
13112
13113       evdw=0.0D0
13114 !cccc      energy_dec=.false.
13115 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13116       evdw=0.0D0
13117       lprn=.false.
13118 !     if (icall.eq.0) lprn=.false.
13119 !el      ind=0
13120       do i=iatsc_s,iatsc_e
13121         itypi=itype(i,1)
13122         if (itypi.eq.ntyp1) cycle
13123         itypi1=itype(i+1,1)
13124         xi=c(1,nres+i)
13125         yi=c(2,nres+i)
13126         zi=c(3,nres+i)
13127           xi=mod(xi,boxxsize)
13128           if (xi.lt.0) xi=xi+boxxsize
13129           yi=mod(yi,boxysize)
13130           if (yi.lt.0) yi=yi+boxysize
13131           zi=mod(zi,boxzsize)
13132           if (zi.lt.0) zi=zi+boxzsize
13133        if ((zi.gt.bordlipbot)    &
13134         .and.(zi.lt.bordliptop)) then
13135 !C the energy transfer exist
13136         if (zi.lt.buflipbot) then
13137 !C what fraction I am in
13138          fracinbuf=1.0d0-    &
13139              ((zi-bordlipbot)/lipbufthick)
13140 !C lipbufthick is thickenes of lipid buffore
13141          sslipi=sscalelip(fracinbuf)
13142          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13143         elseif (zi.gt.bufliptop) then
13144          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13145          sslipi=sscalelip(fracinbuf)
13146          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13147         else
13148          sslipi=1.0d0
13149          ssgradlipi=0.0
13150         endif
13151        else
13152          sslipi=0.0d0
13153          ssgradlipi=0.0
13154        endif
13155
13156         dxi=dc_norm(1,nres+i)
13157         dyi=dc_norm(2,nres+i)
13158         dzi=dc_norm(3,nres+i)
13159 !        dsci_inv=dsc_inv(itypi)
13160         dsci_inv=vbld_inv(i+nres)
13161 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13162 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13163 !
13164 ! Calculate SC interaction energy.
13165 !
13166         do iint=1,nint_gr(i)
13167           do j=istart(i,iint),iend(i,iint)
13168             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13169 !              call dyn_ssbond_ene(i,j,evdwij)
13170 !              evdw=evdw+evdwij
13171 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13172 !                              'evdw',i,j,evdwij,' ss'
13173 !              if (energy_dec) write (iout,*) &
13174 !                              'evdw',i,j,evdwij,' ss'
13175 !             do k=j+1,iend(i,iint)
13176 !C search over all next residues
13177 !              if (dyn_ss_mask(k)) then
13178 !C check if they are cysteins
13179 !C              write(iout,*) 'k=',k
13180
13181 !c              write(iout,*) "PRZED TRI", evdwij
13182 !               evdwij_przed_tri=evdwij
13183 !              call triple_ssbond_ene(i,j,k,evdwij)
13184 !c               if(evdwij_przed_tri.ne.evdwij) then
13185 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13186 !c               endif
13187
13188 !c              write(iout,*) "PO TRI", evdwij
13189 !C call the energy function that removes the artifical triple disulfide
13190 !C bond the soubroutine is located in ssMD.F
13191 !              evdw=evdw+evdwij
13192               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13193                             'evdw',i,j,evdwij,'tss'
13194 !              endif!dyn_ss_mask(k)
13195 !             enddo! k
13196
13197             ELSE
13198 !el            ind=ind+1
13199             itypj=itype(j,1)
13200             if (itypj.eq.ntyp1) cycle
13201 !            dscj_inv=dsc_inv(itypj)
13202             dscj_inv=vbld_inv(j+nres)
13203 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13204 !     &       1.0d0/vbld(j+nres)
13205 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13206             sig0ij=sigma(itypi,itypj)
13207             chi1=chi(itypi,itypj)
13208             chi2=chi(itypj,itypi)
13209             chi12=chi1*chi2
13210             chip1=chip(itypi)
13211             chip2=chip(itypj)
13212             chip12=chip1*chip2
13213             alf1=alp(itypi)
13214             alf2=alp(itypj)
13215             alf12=0.5D0*(alf1+alf2)
13216             xj=c(1,nres+j)
13217             yj=c(2,nres+j)
13218             zj=c(3,nres+j)
13219 ! Searching for nearest neighbour
13220           xj=mod(xj,boxxsize)
13221           if (xj.lt.0) xj=xj+boxxsize
13222           yj=mod(yj,boxysize)
13223           if (yj.lt.0) yj=yj+boxysize
13224           zj=mod(zj,boxzsize)
13225           if (zj.lt.0) zj=zj+boxzsize
13226        if ((zj.gt.bordlipbot)   &
13227       .and.(zj.lt.bordliptop)) then
13228 !C the energy transfer exist
13229         if (zj.lt.buflipbot) then
13230 !C what fraction I am in
13231          fracinbuf=1.0d0-  &
13232              ((zj-bordlipbot)/lipbufthick)
13233 !C lipbufthick is thickenes of lipid buffore
13234          sslipj=sscalelip(fracinbuf)
13235          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13236         elseif (zj.gt.bufliptop) then
13237          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13238          sslipj=sscalelip(fracinbuf)
13239          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13240         else
13241          sslipj=1.0d0
13242          ssgradlipj=0.0
13243         endif
13244        else
13245          sslipj=0.0d0
13246          ssgradlipj=0.0
13247        endif
13248       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13249        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13250       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13251        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13252
13253           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13254           xj_safe=xj
13255           yj_safe=yj
13256           zj_safe=zj
13257           subchap=0
13258           do xshift=-1,1
13259           do yshift=-1,1
13260           do zshift=-1,1
13261           xj=xj_safe+xshift*boxxsize
13262           yj=yj_safe+yshift*boxysize
13263           zj=zj_safe+zshift*boxzsize
13264           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13265           if(dist_temp.lt.dist_init) then
13266             dist_init=dist_temp
13267             xj_temp=xj
13268             yj_temp=yj
13269             zj_temp=zj
13270             subchap=1
13271           endif
13272           enddo
13273           enddo
13274           enddo
13275           if (subchap.eq.1) then
13276           xj=xj_temp-xi
13277           yj=yj_temp-yi
13278           zj=zj_temp-zi
13279           else
13280           xj=xj_safe-xi
13281           yj=yj_safe-yi
13282           zj=zj_safe-zi
13283           endif
13284
13285             dxj=dc_norm(1,nres+j)
13286             dyj=dc_norm(2,nres+j)
13287             dzj=dc_norm(3,nres+j)
13288             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13289             rij=dsqrt(rrij)
13290             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13291             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13292             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13293             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13294             if (sss_ele_cut.le.0.0) cycle
13295             if (sss.lt.1.0d0) then
13296
13297 ! Calculate angle-dependent terms of energy and contributions to their
13298 ! derivatives.
13299               call sc_angular
13300               sigsq=1.0D0/sigsq
13301               sig=sig0ij*dsqrt(sigsq)
13302               rij_shift=1.0D0/rij-sig+sig0ij
13303 ! for diagnostics; uncomment
13304 !              rij_shift=1.2*sig0ij
13305 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13306               if (rij_shift.le.0.0D0) then
13307                 evdw=1.0D20
13308 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13309 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13310 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13311                 return
13312               endif
13313               sigder=-sig*sigsq
13314 !---------------------------------------------------------------
13315               rij_shift=1.0D0/rij_shift
13316               fac=rij_shift**expon
13317               e1=fac*fac*aa
13318               e2=fac*bb
13319               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13320               eps2der=evdwij*eps3rt
13321               eps3der=evdwij*eps2rt
13322 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13323 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13324               evdwij=evdwij*eps2rt*eps3rt
13325               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13326               if (lprn) then
13327               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13328               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13329               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13330                 restyp(itypi,1),i,restyp(itypj,1),j,&
13331                 epsi,sigm,chi1,chi2,chip1,chip2,&
13332                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13333                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13334                 evdwij
13335               endif
13336
13337               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13338                               'evdw',i,j,evdwij
13339 !              if (energy_dec) write (iout,*) &
13340 !                              'evdw',i,j,evdwij,"egb_long"
13341
13342 ! Calculate gradient components.
13343               e1=e1*eps1*eps2rt**2*eps3rt**2
13344               fac=-expon*(e1+evdwij)*rij_shift
13345               sigder=fac*sigder
13346               fac=rij*fac
13347               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13348             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13349             /sigmaii(itypi,itypj))
13350 !              fac=0.0d0
13351 ! Calculate the radial part of the gradient
13352               gg(1)=xj*fac
13353               gg(2)=yj*fac
13354               gg(3)=zj*fac
13355 ! Calculate angular part of the gradient.
13356               call sc_grad_scale(1.0d0-sss)
13357             ENDIF    !mask_dyn_ss
13358             endif
13359           enddo      ! j
13360         enddo        ! iint
13361       enddo          ! i
13362 !      write (iout,*) "Number of loop steps in EGB:",ind
13363 !ccc      energy_dec=.false.
13364       return
13365       end subroutine egb_long
13366 !-----------------------------------------------------------------------------
13367       subroutine egb_short(evdw)
13368 !
13369 ! This subroutine calculates the interaction energy of nonbonded side chains
13370 ! assuming the Gay-Berne potential of interaction.
13371 !
13372       use calc_data
13373 !      implicit real*8 (a-h,o-z)
13374 !      include 'DIMENSIONS'
13375 !      include 'COMMON.GEO'
13376 !      include 'COMMON.VAR'
13377 !      include 'COMMON.LOCAL'
13378 !      include 'COMMON.CHAIN'
13379 !      include 'COMMON.DERIV'
13380 !      include 'COMMON.NAMES'
13381 !      include 'COMMON.INTERACT'
13382 !      include 'COMMON.IOUNITS'
13383 !      include 'COMMON.CALC'
13384 !      include 'COMMON.CONTROL'
13385       logical :: lprn
13386 !el local variables
13387       integer :: iint,itypi,itypi1,itypj,subchap
13388       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13389       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13390       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13391                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13392                     ssgradlipi,ssgradlipj
13393       evdw=0.0D0
13394 !cccc      energy_dec=.false.
13395 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13396       evdw=0.0D0
13397       lprn=.false.
13398 !     if (icall.eq.0) lprn=.false.
13399 !el      ind=0
13400       do i=iatsc_s,iatsc_e
13401         itypi=itype(i,1)
13402         if (itypi.eq.ntyp1) cycle
13403         itypi1=itype(i+1,1)
13404         xi=c(1,nres+i)
13405         yi=c(2,nres+i)
13406         zi=c(3,nres+i)
13407           xi=mod(xi,boxxsize)
13408           if (xi.lt.0) xi=xi+boxxsize
13409           yi=mod(yi,boxysize)
13410           if (yi.lt.0) yi=yi+boxysize
13411           zi=mod(zi,boxzsize)
13412           if (zi.lt.0) zi=zi+boxzsize
13413        if ((zi.gt.bordlipbot)    &
13414         .and.(zi.lt.bordliptop)) then
13415 !C the energy transfer exist
13416         if (zi.lt.buflipbot) then
13417 !C what fraction I am in
13418          fracinbuf=1.0d0-    &
13419              ((zi-bordlipbot)/lipbufthick)
13420 !C lipbufthick is thickenes of lipid buffore
13421          sslipi=sscalelip(fracinbuf)
13422          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13423         elseif (zi.gt.bufliptop) then
13424          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13425          sslipi=sscalelip(fracinbuf)
13426          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13427         else
13428          sslipi=1.0d0
13429          ssgradlipi=0.0
13430         endif
13431        else
13432          sslipi=0.0d0
13433          ssgradlipi=0.0
13434        endif
13435
13436         dxi=dc_norm(1,nres+i)
13437         dyi=dc_norm(2,nres+i)
13438         dzi=dc_norm(3,nres+i)
13439 !        dsci_inv=dsc_inv(itypi)
13440         dsci_inv=vbld_inv(i+nres)
13441
13442         dxi=dc_norm(1,nres+i)
13443         dyi=dc_norm(2,nres+i)
13444         dzi=dc_norm(3,nres+i)
13445 !        dsci_inv=dsc_inv(itypi)
13446         dsci_inv=vbld_inv(i+nres)
13447 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13448 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13449 !
13450 ! Calculate SC interaction energy.
13451 !
13452         do iint=1,nint_gr(i)
13453           do j=istart(i,iint),iend(i,iint)
13454             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13455               call dyn_ssbond_ene(i,j,evdwij)
13456               evdw=evdw+evdwij
13457               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13458                               'evdw',i,j,evdwij,' ss'
13459              do k=j+1,iend(i,iint)
13460 !C search over all next residues
13461               if (dyn_ss_mask(k)) then
13462 !C check if they are cysteins
13463 !C              write(iout,*) 'k=',k
13464
13465 !c              write(iout,*) "PRZED TRI", evdwij
13466 !               evdwij_przed_tri=evdwij
13467               call triple_ssbond_ene(i,j,k,evdwij)
13468 !c               if(evdwij_przed_tri.ne.evdwij) then
13469 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13470 !c               endif
13471
13472 !c              write(iout,*) "PO TRI", evdwij
13473 !C call the energy function that removes the artifical triple disulfide
13474 !C bond the soubroutine is located in ssMD.F
13475               evdw=evdw+evdwij
13476               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13477                             'evdw',i,j,evdwij,'tss'
13478               endif!dyn_ss_mask(k)
13479              enddo! k
13480
13481 !              if (energy_dec) write (iout,*) &
13482 !                              'evdw',i,j,evdwij,' ss'
13483             ELSE
13484 !el            ind=ind+1
13485             itypj=itype(j,1)
13486             if (itypj.eq.ntyp1) cycle
13487 !            dscj_inv=dsc_inv(itypj)
13488             dscj_inv=vbld_inv(j+nres)
13489 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13490 !     &       1.0d0/vbld(j+nres)
13491 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13492             sig0ij=sigma(itypi,itypj)
13493             chi1=chi(itypi,itypj)
13494             chi2=chi(itypj,itypi)
13495             chi12=chi1*chi2
13496             chip1=chip(itypi)
13497             chip2=chip(itypj)
13498             chip12=chip1*chip2
13499             alf1=alp(itypi)
13500             alf2=alp(itypj)
13501             alf12=0.5D0*(alf1+alf2)
13502 !            xj=c(1,nres+j)-xi
13503 !            yj=c(2,nres+j)-yi
13504 !            zj=c(3,nres+j)-zi
13505             xj=c(1,nres+j)
13506             yj=c(2,nres+j)
13507             zj=c(3,nres+j)
13508 ! Searching for nearest neighbour
13509           xj=mod(xj,boxxsize)
13510           if (xj.lt.0) xj=xj+boxxsize
13511           yj=mod(yj,boxysize)
13512           if (yj.lt.0) yj=yj+boxysize
13513           zj=mod(zj,boxzsize)
13514           if (zj.lt.0) zj=zj+boxzsize
13515        if ((zj.gt.bordlipbot)   &
13516       .and.(zj.lt.bordliptop)) then
13517 !C the energy transfer exist
13518         if (zj.lt.buflipbot) then
13519 !C what fraction I am in
13520          fracinbuf=1.0d0-  &
13521              ((zj-bordlipbot)/lipbufthick)
13522 !C lipbufthick is thickenes of lipid buffore
13523          sslipj=sscalelip(fracinbuf)
13524          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13525         elseif (zj.gt.bufliptop) then
13526          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13527          sslipj=sscalelip(fracinbuf)
13528          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13529         else
13530          sslipj=1.0d0
13531          ssgradlipj=0.0
13532         endif
13533        else
13534          sslipj=0.0d0
13535          ssgradlipj=0.0
13536        endif
13537       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13538        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13539       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13540        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13541
13542           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13543           xj_safe=xj
13544           yj_safe=yj
13545           zj_safe=zj
13546           subchap=0
13547
13548           do xshift=-1,1
13549           do yshift=-1,1
13550           do zshift=-1,1
13551           xj=xj_safe+xshift*boxxsize
13552           yj=yj_safe+yshift*boxysize
13553           zj=zj_safe+zshift*boxzsize
13554           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13555           if(dist_temp.lt.dist_init) then
13556             dist_init=dist_temp
13557             xj_temp=xj
13558             yj_temp=yj
13559             zj_temp=zj
13560             subchap=1
13561           endif
13562           enddo
13563           enddo
13564           enddo
13565           if (subchap.eq.1) then
13566           xj=xj_temp-xi
13567           yj=yj_temp-yi
13568           zj=zj_temp-zi
13569           else
13570           xj=xj_safe-xi
13571           yj=yj_safe-yi
13572           zj=zj_safe-zi
13573           endif
13574
13575             dxj=dc_norm(1,nres+j)
13576             dyj=dc_norm(2,nres+j)
13577             dzj=dc_norm(3,nres+j)
13578             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13579             rij=dsqrt(rrij)
13580             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13581             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13582             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13583             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13584             if (sss_ele_cut.le.0.0) cycle
13585
13586             if (sss.gt.0.0d0) then
13587
13588 ! Calculate angle-dependent terms of energy and contributions to their
13589 ! derivatives.
13590               call sc_angular
13591               sigsq=1.0D0/sigsq
13592               sig=sig0ij*dsqrt(sigsq)
13593               rij_shift=1.0D0/rij-sig+sig0ij
13594 ! for diagnostics; uncomment
13595 !              rij_shift=1.2*sig0ij
13596 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13597               if (rij_shift.le.0.0D0) then
13598                 evdw=1.0D20
13599 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13600 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13601 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13602                 return
13603               endif
13604               sigder=-sig*sigsq
13605 !---------------------------------------------------------------
13606               rij_shift=1.0D0/rij_shift
13607               fac=rij_shift**expon
13608               e1=fac*fac*aa
13609               e2=fac*bb
13610               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13611               eps2der=evdwij*eps3rt
13612               eps3der=evdwij*eps2rt
13613 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13614 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13615               evdwij=evdwij*eps2rt*eps3rt
13616               evdw=evdw+evdwij*sss*sss_ele_cut
13617               if (lprn) then
13618               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13619               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13620               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13621                 restyp(itypi,1),i,restyp(itypj,1),j,&
13622                 epsi,sigm,chi1,chi2,chip1,chip2,&
13623                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13624                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13625                 evdwij
13626               endif
13627
13628               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13629                               'evdw',i,j,evdwij
13630 !              if (energy_dec) write (iout,*) &
13631 !                              'evdw',i,j,evdwij,"egb_short"
13632
13633 ! Calculate gradient components.
13634               e1=e1*eps1*eps2rt**2*eps3rt**2
13635               fac=-expon*(e1+evdwij)*rij_shift
13636               sigder=fac*sigder
13637               fac=rij*fac
13638               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13639             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13640             /sigmaii(itypi,itypj))
13641
13642 !              fac=0.0d0
13643 ! Calculate the radial part of the gradient
13644               gg(1)=xj*fac
13645               gg(2)=yj*fac
13646               gg(3)=zj*fac
13647 ! Calculate angular part of the gradient.
13648               call sc_grad_scale(sss)
13649             endif
13650           ENDIF !mask_dyn_ss
13651           enddo      ! j
13652         enddo        ! iint
13653       enddo          ! i
13654 !      write (iout,*) "Number of loop steps in EGB:",ind
13655 !ccc      energy_dec=.false.
13656       return
13657       end subroutine egb_short
13658 !-----------------------------------------------------------------------------
13659       subroutine egbv_long(evdw)
13660 !
13661 ! This subroutine calculates the interaction energy of nonbonded side chains
13662 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13663 !
13664       use calc_data
13665 !      implicit real*8 (a-h,o-z)
13666 !      include 'DIMENSIONS'
13667 !      include 'COMMON.GEO'
13668 !      include 'COMMON.VAR'
13669 !      include 'COMMON.LOCAL'
13670 !      include 'COMMON.CHAIN'
13671 !      include 'COMMON.DERIV'
13672 !      include 'COMMON.NAMES'
13673 !      include 'COMMON.INTERACT'
13674 !      include 'COMMON.IOUNITS'
13675 !      include 'COMMON.CALC'
13676       use comm_srutu
13677 !el      integer :: icall
13678 !el      common /srutu/ icall
13679       logical :: lprn
13680 !el local variables
13681       integer :: iint,itypi,itypi1,itypj
13682       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13683       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13684       evdw=0.0D0
13685 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13686       evdw=0.0D0
13687       lprn=.false.
13688 !     if (icall.eq.0) lprn=.true.
13689 !el      ind=0
13690       do i=iatsc_s,iatsc_e
13691         itypi=itype(i,1)
13692         if (itypi.eq.ntyp1) cycle
13693         itypi1=itype(i+1,1)
13694         xi=c(1,nres+i)
13695         yi=c(2,nres+i)
13696         zi=c(3,nres+i)
13697         dxi=dc_norm(1,nres+i)
13698         dyi=dc_norm(2,nres+i)
13699         dzi=dc_norm(3,nres+i)
13700 !        dsci_inv=dsc_inv(itypi)
13701         dsci_inv=vbld_inv(i+nres)
13702 !
13703 ! Calculate SC interaction energy.
13704 !
13705         do iint=1,nint_gr(i)
13706           do j=istart(i,iint),iend(i,iint)
13707 !el            ind=ind+1
13708             itypj=itype(j,1)
13709             if (itypj.eq.ntyp1) cycle
13710 !            dscj_inv=dsc_inv(itypj)
13711             dscj_inv=vbld_inv(j+nres)
13712             sig0ij=sigma(itypi,itypj)
13713             r0ij=r0(itypi,itypj)
13714             chi1=chi(itypi,itypj)
13715             chi2=chi(itypj,itypi)
13716             chi12=chi1*chi2
13717             chip1=chip(itypi)
13718             chip2=chip(itypj)
13719             chip12=chip1*chip2
13720             alf1=alp(itypi)
13721             alf2=alp(itypj)
13722             alf12=0.5D0*(alf1+alf2)
13723             xj=c(1,nres+j)-xi
13724             yj=c(2,nres+j)-yi
13725             zj=c(3,nres+j)-zi
13726             dxj=dc_norm(1,nres+j)
13727             dyj=dc_norm(2,nres+j)
13728             dzj=dc_norm(3,nres+j)
13729             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13730             rij=dsqrt(rrij)
13731
13732             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13733
13734             if (sss.lt.1.0d0) then
13735
13736 ! Calculate angle-dependent terms of energy and contributions to their
13737 ! derivatives.
13738               call sc_angular
13739               sigsq=1.0D0/sigsq
13740               sig=sig0ij*dsqrt(sigsq)
13741               rij_shift=1.0D0/rij-sig+r0ij
13742 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13743               if (rij_shift.le.0.0D0) then
13744                 evdw=1.0D20
13745                 return
13746               endif
13747               sigder=-sig*sigsq
13748 !---------------------------------------------------------------
13749               rij_shift=1.0D0/rij_shift
13750               fac=rij_shift**expon
13751               e1=fac*fac*aa_aq(itypi,itypj)
13752               e2=fac*bb_aq(itypi,itypj)
13753               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13754               eps2der=evdwij*eps3rt
13755               eps3der=evdwij*eps2rt
13756               fac_augm=rrij**expon
13757               e_augm=augm(itypi,itypj)*fac_augm
13758               evdwij=evdwij*eps2rt*eps3rt
13759               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13760               if (lprn) then
13761               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13762               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13763               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13764                 restyp(itypi,1),i,restyp(itypj,1),j,&
13765                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13766                 chi1,chi2,chip1,chip2,&
13767                 eps1,eps2rt**2,eps3rt**2,&
13768                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13769                 evdwij+e_augm
13770               endif
13771 ! Calculate gradient components.
13772               e1=e1*eps1*eps2rt**2*eps3rt**2
13773               fac=-expon*(e1+evdwij)*rij_shift
13774               sigder=fac*sigder
13775               fac=rij*fac-2*expon*rrij*e_augm
13776 ! Calculate the radial part of the gradient
13777               gg(1)=xj*fac
13778               gg(2)=yj*fac
13779               gg(3)=zj*fac
13780 ! Calculate angular part of the gradient.
13781               call sc_grad_scale(1.0d0-sss)
13782             endif
13783           enddo      ! j
13784         enddo        ! iint
13785       enddo          ! i
13786       end subroutine egbv_long
13787 !-----------------------------------------------------------------------------
13788       subroutine egbv_short(evdw)
13789 !
13790 ! This subroutine calculates the interaction energy of nonbonded side chains
13791 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13792 !
13793       use calc_data
13794 !      implicit real*8 (a-h,o-z)
13795 !      include 'DIMENSIONS'
13796 !      include 'COMMON.GEO'
13797 !      include 'COMMON.VAR'
13798 !      include 'COMMON.LOCAL'
13799 !      include 'COMMON.CHAIN'
13800 !      include 'COMMON.DERIV'
13801 !      include 'COMMON.NAMES'
13802 !      include 'COMMON.INTERACT'
13803 !      include 'COMMON.IOUNITS'
13804 !      include 'COMMON.CALC'
13805       use comm_srutu
13806 !el      integer :: icall
13807 !el      common /srutu/ icall
13808       logical :: lprn
13809 !el local variables
13810       integer :: iint,itypi,itypi1,itypj
13811       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13812       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13813       evdw=0.0D0
13814 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13815       evdw=0.0D0
13816       lprn=.false.
13817 !     if (icall.eq.0) lprn=.true.
13818 !el      ind=0
13819       do i=iatsc_s,iatsc_e
13820         itypi=itype(i,1)
13821         if (itypi.eq.ntyp1) cycle
13822         itypi1=itype(i+1,1)
13823         xi=c(1,nres+i)
13824         yi=c(2,nres+i)
13825         zi=c(3,nres+i)
13826         dxi=dc_norm(1,nres+i)
13827         dyi=dc_norm(2,nres+i)
13828         dzi=dc_norm(3,nres+i)
13829 !        dsci_inv=dsc_inv(itypi)
13830         dsci_inv=vbld_inv(i+nres)
13831 !
13832 ! Calculate SC interaction energy.
13833 !
13834         do iint=1,nint_gr(i)
13835           do j=istart(i,iint),iend(i,iint)
13836 !el            ind=ind+1
13837             itypj=itype(j,1)
13838             if (itypj.eq.ntyp1) cycle
13839 !            dscj_inv=dsc_inv(itypj)
13840             dscj_inv=vbld_inv(j+nres)
13841             sig0ij=sigma(itypi,itypj)
13842             r0ij=r0(itypi,itypj)
13843             chi1=chi(itypi,itypj)
13844             chi2=chi(itypj,itypi)
13845             chi12=chi1*chi2
13846             chip1=chip(itypi)
13847             chip2=chip(itypj)
13848             chip12=chip1*chip2
13849             alf1=alp(itypi)
13850             alf2=alp(itypj)
13851             alf12=0.5D0*(alf1+alf2)
13852             xj=c(1,nres+j)-xi
13853             yj=c(2,nres+j)-yi
13854             zj=c(3,nres+j)-zi
13855             dxj=dc_norm(1,nres+j)
13856             dyj=dc_norm(2,nres+j)
13857             dzj=dc_norm(3,nres+j)
13858             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13859             rij=dsqrt(rrij)
13860
13861             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13862
13863             if (sss.gt.0.0d0) then
13864
13865 ! Calculate angle-dependent terms of energy and contributions to their
13866 ! derivatives.
13867               call sc_angular
13868               sigsq=1.0D0/sigsq
13869               sig=sig0ij*dsqrt(sigsq)
13870               rij_shift=1.0D0/rij-sig+r0ij
13871 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13872               if (rij_shift.le.0.0D0) then
13873                 evdw=1.0D20
13874                 return
13875               endif
13876               sigder=-sig*sigsq
13877 !---------------------------------------------------------------
13878               rij_shift=1.0D0/rij_shift
13879               fac=rij_shift**expon
13880               e1=fac*fac*aa_aq(itypi,itypj)
13881               e2=fac*bb_aq(itypi,itypj)
13882               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13883               eps2der=evdwij*eps3rt
13884               eps3der=evdwij*eps2rt
13885               fac_augm=rrij**expon
13886               e_augm=augm(itypi,itypj)*fac_augm
13887               evdwij=evdwij*eps2rt*eps3rt
13888               evdw=evdw+(evdwij+e_augm)*sss
13889               if (lprn) then
13890               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13891               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13892               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13893                 restyp(itypi,1),i,restyp(itypj,1),j,&
13894                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13895                 chi1,chi2,chip1,chip2,&
13896                 eps1,eps2rt**2,eps3rt**2,&
13897                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13898                 evdwij+e_augm
13899               endif
13900 ! Calculate gradient components.
13901               e1=e1*eps1*eps2rt**2*eps3rt**2
13902               fac=-expon*(e1+evdwij)*rij_shift
13903               sigder=fac*sigder
13904               fac=rij*fac-2*expon*rrij*e_augm
13905 ! Calculate the radial part of the gradient
13906               gg(1)=xj*fac
13907               gg(2)=yj*fac
13908               gg(3)=zj*fac
13909 ! Calculate angular part of the gradient.
13910               call sc_grad_scale(sss)
13911             endif
13912           enddo      ! j
13913         enddo        ! iint
13914       enddo          ! i
13915       end subroutine egbv_short
13916 !-----------------------------------------------------------------------------
13917       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13918 !
13919 ! This subroutine calculates the average interaction energy and its gradient
13920 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13921 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13922 ! The potential depends both on the distance of peptide-group centers and on
13923 ! the orientation of the CA-CA virtual bonds.
13924 !
13925 !      implicit real*8 (a-h,o-z)
13926
13927       use comm_locel
13928 #ifdef MPI
13929       include 'mpif.h'
13930 #endif
13931 !      include 'DIMENSIONS'
13932 !      include 'COMMON.CONTROL'
13933 !      include 'COMMON.SETUP'
13934 !      include 'COMMON.IOUNITS'
13935 !      include 'COMMON.GEO'
13936 !      include 'COMMON.VAR'
13937 !      include 'COMMON.LOCAL'
13938 !      include 'COMMON.CHAIN'
13939 !      include 'COMMON.DERIV'
13940 !      include 'COMMON.INTERACT'
13941 !      include 'COMMON.CONTACTS'
13942 !      include 'COMMON.TORSION'
13943 !      include 'COMMON.VECTORS'
13944 !      include 'COMMON.FFIELD'
13945 !      include 'COMMON.TIME1'
13946       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13947       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13948       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13949 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13950       real(kind=8),dimension(4) :: muij
13951 !el      integer :: num_conti,j1,j2
13952 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13953 !el                   dz_normi,xmedi,ymedi,zmedi
13954 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13955 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13956 !el          num_conti,j1,j2
13957 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13958 #ifdef MOMENT
13959       real(kind=8) :: scal_el=1.0d0
13960 #else
13961       real(kind=8) :: scal_el=0.5d0
13962 #endif
13963 ! 12/13/98
13964 ! 13-go grudnia roku pamietnego...
13965       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13966                                              0.0d0,1.0d0,0.0d0,&
13967                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13968 !el local variables
13969       integer :: i,j,k
13970       real(kind=8) :: fac
13971       real(kind=8) :: dxj,dyj,dzj
13972       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13973
13974 !      allocate(num_cont_hb(nres)) !(maxres)
13975 !d      write(iout,*) 'In EELEC'
13976 !d      do i=1,nloctyp
13977 !d        write(iout,*) 'Type',i
13978 !d        write(iout,*) 'B1',B1(:,i)
13979 !d        write(iout,*) 'B2',B2(:,i)
13980 !d        write(iout,*) 'CC',CC(:,:,i)
13981 !d        write(iout,*) 'DD',DD(:,:,i)
13982 !d        write(iout,*) 'EE',EE(:,:,i)
13983 !d      enddo
13984 !d      call check_vecgrad
13985 !d      stop
13986       if (icheckgrad.eq.1) then
13987         do i=1,nres-1
13988           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13989           do k=1,3
13990             dc_norm(k,i)=dc(k,i)*fac
13991           enddo
13992 !          write (iout,*) 'i',i,' fac',fac
13993         enddo
13994       endif
13995       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13996           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13997           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13998 !        call vec_and_deriv
13999 #ifdef TIMING
14000         time01=MPI_Wtime()
14001 #endif
14002 !        print *, "before set matrices"
14003         call set_matrices
14004 !        print *,"after set martices"
14005 #ifdef TIMING
14006         time_mat=time_mat+MPI_Wtime()-time01
14007 #endif
14008       endif
14009 !d      do i=1,nres-1
14010 !d        write (iout,*) 'i=',i
14011 !d        do k=1,3
14012 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14013 !d        enddo
14014 !d        do k=1,3
14015 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14016 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14017 !d        enddo
14018 !d      enddo
14019       t_eelecij=0.0d0
14020       ees=0.0D0
14021       evdw1=0.0D0
14022       eel_loc=0.0d0
14023       eello_turn3=0.0d0
14024       eello_turn4=0.0d0
14025 !el      ind=0
14026       do i=1,nres
14027         num_cont_hb(i)=0
14028       enddo
14029 !d      print '(a)','Enter EELEC'
14030 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14031 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14032 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14033       do i=1,nres
14034         gel_loc_loc(i)=0.0d0
14035         gcorr_loc(i)=0.0d0
14036       enddo
14037 !
14038 !
14039 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14040 !
14041 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14042 !
14043       do i=iturn3_start,iturn3_end
14044         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14045         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14046         dxi=dc(1,i)
14047         dyi=dc(2,i)
14048         dzi=dc(3,i)
14049         dx_normi=dc_norm(1,i)
14050         dy_normi=dc_norm(2,i)
14051         dz_normi=dc_norm(3,i)
14052         xmedi=c(1,i)+0.5d0*dxi
14053         ymedi=c(2,i)+0.5d0*dyi
14054         zmedi=c(3,i)+0.5d0*dzi
14055           xmedi=dmod(xmedi,boxxsize)
14056           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14057           ymedi=dmod(ymedi,boxysize)
14058           if (ymedi.lt.0) ymedi=ymedi+boxysize
14059           zmedi=dmod(zmedi,boxzsize)
14060           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14061         num_conti=0
14062         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14063         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14064         num_cont_hb(i)=num_conti
14065       enddo
14066       do i=iturn4_start,iturn4_end
14067         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14068           .or. itype(i+3,1).eq.ntyp1 &
14069           .or. itype(i+4,1).eq.ntyp1) cycle
14070         dxi=dc(1,i)
14071         dyi=dc(2,i)
14072         dzi=dc(3,i)
14073         dx_normi=dc_norm(1,i)
14074         dy_normi=dc_norm(2,i)
14075         dz_normi=dc_norm(3,i)
14076         xmedi=c(1,i)+0.5d0*dxi
14077         ymedi=c(2,i)+0.5d0*dyi
14078         zmedi=c(3,i)+0.5d0*dzi
14079           xmedi=dmod(xmedi,boxxsize)
14080           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14081           ymedi=dmod(ymedi,boxysize)
14082           if (ymedi.lt.0) ymedi=ymedi+boxysize
14083           zmedi=dmod(zmedi,boxzsize)
14084           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14085         num_conti=num_cont_hb(i)
14086         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14087         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14088           call eturn4(i,eello_turn4)
14089         num_cont_hb(i)=num_conti
14090       enddo   ! i
14091 !
14092 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14093 !
14094       do i=iatel_s,iatel_e
14095         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14096         dxi=dc(1,i)
14097         dyi=dc(2,i)
14098         dzi=dc(3,i)
14099         dx_normi=dc_norm(1,i)
14100         dy_normi=dc_norm(2,i)
14101         dz_normi=dc_norm(3,i)
14102         xmedi=c(1,i)+0.5d0*dxi
14103         ymedi=c(2,i)+0.5d0*dyi
14104         zmedi=c(3,i)+0.5d0*dzi
14105           xmedi=dmod(xmedi,boxxsize)
14106           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14107           ymedi=dmod(ymedi,boxysize)
14108           if (ymedi.lt.0) ymedi=ymedi+boxysize
14109           zmedi=dmod(zmedi,boxzsize)
14110           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14111 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14112         num_conti=num_cont_hb(i)
14113         do j=ielstart(i),ielend(i)
14114           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14115           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14116         enddo ! j
14117         num_cont_hb(i)=num_conti
14118       enddo   ! i
14119 !      write (iout,*) "Number of loop steps in EELEC:",ind
14120 !d      do i=1,nres
14121 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14122 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14123 !d      enddo
14124 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14125 !cc      eel_loc=eel_loc+eello_turn3
14126 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14127       return
14128       end subroutine eelec_scale
14129 !-----------------------------------------------------------------------------
14130       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14131 !      implicit real*8 (a-h,o-z)
14132
14133       use comm_locel
14134 !      include 'DIMENSIONS'
14135 #ifdef MPI
14136       include "mpif.h"
14137 #endif
14138 !      include 'COMMON.CONTROL'
14139 !      include 'COMMON.IOUNITS'
14140 !      include 'COMMON.GEO'
14141 !      include 'COMMON.VAR'
14142 !      include 'COMMON.LOCAL'
14143 !      include 'COMMON.CHAIN'
14144 !      include 'COMMON.DERIV'
14145 !      include 'COMMON.INTERACT'
14146 !      include 'COMMON.CONTACTS'
14147 !      include 'COMMON.TORSION'
14148 !      include 'COMMON.VECTORS'
14149 !      include 'COMMON.FFIELD'
14150 !      include 'COMMON.TIME1'
14151       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14152       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14153       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14154 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14155       real(kind=8),dimension(4) :: muij
14156       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14157                     dist_temp, dist_init,sss_grad
14158       integer xshift,yshift,zshift
14159
14160 !el      integer :: num_conti,j1,j2
14161 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14162 !el                   dz_normi,xmedi,ymedi,zmedi
14163 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14164 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14165 !el          num_conti,j1,j2
14166 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14167 #ifdef MOMENT
14168       real(kind=8) :: scal_el=1.0d0
14169 #else
14170       real(kind=8) :: scal_el=0.5d0
14171 #endif
14172 ! 12/13/98
14173 ! 13-go grudnia roku pamietnego...
14174       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14175                                              0.0d0,1.0d0,0.0d0,&
14176                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14177 !el local variables
14178       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14179       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14180       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14181       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14182       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14183       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14184       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14185                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14186                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14187                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14188                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14189                   ecosam,ecosbm,ecosgm,ghalf,time00
14190 !      integer :: maxconts
14191 !      maxconts = nres/4
14192 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14193 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14194 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14195 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14196 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14197 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14198 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14199 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14200 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14201 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14202 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14203 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14204 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14205
14206 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14207 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14208
14209 #ifdef MPI
14210           time00=MPI_Wtime()
14211 #endif
14212 !d      write (iout,*) "eelecij",i,j
14213 !el          ind=ind+1
14214           iteli=itel(i)
14215           itelj=itel(j)
14216           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14217           aaa=app(iteli,itelj)
14218           bbb=bpp(iteli,itelj)
14219           ael6i=ael6(iteli,itelj)
14220           ael3i=ael3(iteli,itelj)
14221           dxj=dc(1,j)
14222           dyj=dc(2,j)
14223           dzj=dc(3,j)
14224           dx_normj=dc_norm(1,j)
14225           dy_normj=dc_norm(2,j)
14226           dz_normj=dc_norm(3,j)
14227 !          xj=c(1,j)+0.5D0*dxj-xmedi
14228 !          yj=c(2,j)+0.5D0*dyj-ymedi
14229 !          zj=c(3,j)+0.5D0*dzj-zmedi
14230           xj=c(1,j)+0.5D0*dxj
14231           yj=c(2,j)+0.5D0*dyj
14232           zj=c(3,j)+0.5D0*dzj
14233           xj=mod(xj,boxxsize)
14234           if (xj.lt.0) xj=xj+boxxsize
14235           yj=mod(yj,boxysize)
14236           if (yj.lt.0) yj=yj+boxysize
14237           zj=mod(zj,boxzsize)
14238           if (zj.lt.0) zj=zj+boxzsize
14239       isubchap=0
14240       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14241       xj_safe=xj
14242       yj_safe=yj
14243       zj_safe=zj
14244       do xshift=-1,1
14245       do yshift=-1,1
14246       do zshift=-1,1
14247           xj=xj_safe+xshift*boxxsize
14248           yj=yj_safe+yshift*boxysize
14249           zj=zj_safe+zshift*boxzsize
14250           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14251           if(dist_temp.lt.dist_init) then
14252             dist_init=dist_temp
14253             xj_temp=xj
14254             yj_temp=yj
14255             zj_temp=zj
14256             isubchap=1
14257           endif
14258        enddo
14259        enddo
14260        enddo
14261        if (isubchap.eq.1) then
14262 !C          print *,i,j
14263           xj=xj_temp-xmedi
14264           yj=yj_temp-ymedi
14265           zj=zj_temp-zmedi
14266        else
14267           xj=xj_safe-xmedi
14268           yj=yj_safe-ymedi
14269           zj=zj_safe-zmedi
14270        endif
14271
14272           rij=xj*xj+yj*yj+zj*zj
14273           rrmij=1.0D0/rij
14274           rij=dsqrt(rij)
14275           rmij=1.0D0/rij
14276 ! For extracting the short-range part of Evdwpp
14277           sss=sscale(rij/rpp(iteli,itelj))
14278             sss_ele_cut=sscale_ele(rij)
14279             sss_ele_grad=sscagrad_ele(rij)
14280             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14281 !             sss_ele_cut=1.0d0
14282 !             sss_ele_grad=0.0d0
14283             if (sss_ele_cut.le.0.0) go to 128
14284
14285           r3ij=rrmij*rmij
14286           r6ij=r3ij*r3ij
14287           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14288           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14289           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14290           fac=cosa-3.0D0*cosb*cosg
14291           ev1=aaa*r6ij*r6ij
14292 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14293           if (j.eq.i+2) ev1=scal_el*ev1
14294           ev2=bbb*r6ij
14295           fac3=ael6i*r6ij
14296           fac4=ael3i*r3ij
14297           evdwij=ev1+ev2
14298           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14299           el2=fac4*fac
14300           eesij=el1+el2
14301 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14302           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14303           ees=ees+eesij*sss_ele_cut
14304           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14305 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14306 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14307 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14308 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14309
14310           if (energy_dec) then
14311               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14312               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14313           endif
14314
14315 !
14316 ! Calculate contributions to the Cartesian gradient.
14317 !
14318 #ifdef SPLITELE
14319           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14320           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14321           fac1=fac
14322           erij(1)=xj*rmij
14323           erij(2)=yj*rmij
14324           erij(3)=zj*rmij
14325 !
14326 ! Radial derivatives. First process both termini of the fragment (i,j)
14327 !
14328           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14329           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14330           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14331 !          do k=1,3
14332 !            ghalf=0.5D0*ggg(k)
14333 !            gelc(k,i)=gelc(k,i)+ghalf
14334 !            gelc(k,j)=gelc(k,j)+ghalf
14335 !          enddo
14336 ! 9/28/08 AL Gradient compotents will be summed only at the end
14337           do k=1,3
14338             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14339             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14340           enddo
14341 !
14342 ! Loop over residues i+1 thru j-1.
14343 !
14344 !grad          do k=i+1,j-1
14345 !grad            do l=1,3
14346 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14347 !grad            enddo
14348 !grad          enddo
14349           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14350           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14351           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14352           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14353           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14354           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14355 !          do k=1,3
14356 !            ghalf=0.5D0*ggg(k)
14357 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14358 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14359 !          enddo
14360 ! 9/28/08 AL Gradient compotents will be summed only at the end
14361           do k=1,3
14362             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14363             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14364           enddo
14365 !
14366 ! Loop over residues i+1 thru j-1.
14367 !
14368 !grad          do k=i+1,j-1
14369 !grad            do l=1,3
14370 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14371 !grad            enddo
14372 !grad          enddo
14373 #else
14374           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14375           facel=(el1+eesij)*sss_ele_cut
14376           fac1=fac
14377           fac=-3*rrmij*(facvdw+facvdw+facel)
14378           erij(1)=xj*rmij
14379           erij(2)=yj*rmij
14380           erij(3)=zj*rmij
14381 !
14382 ! Radial derivatives. First process both termini of the fragment (i,j)
14383 !
14384           ggg(1)=fac*xj
14385           ggg(2)=fac*yj
14386           ggg(3)=fac*zj
14387 !          do k=1,3
14388 !            ghalf=0.5D0*ggg(k)
14389 !            gelc(k,i)=gelc(k,i)+ghalf
14390 !            gelc(k,j)=gelc(k,j)+ghalf
14391 !          enddo
14392 ! 9/28/08 AL Gradient compotents will be summed only at the end
14393           do k=1,3
14394             gelc_long(k,j)=gelc(k,j)+ggg(k)
14395             gelc_long(k,i)=gelc(k,i)-ggg(k)
14396           enddo
14397 !
14398 ! Loop over residues i+1 thru j-1.
14399 !
14400 !grad          do k=i+1,j-1
14401 !grad            do l=1,3
14402 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14403 !grad            enddo
14404 !grad          enddo
14405 ! 9/28/08 AL Gradient compotents will be summed only at the end
14406           ggg(1)=facvdw*xj
14407           ggg(2)=facvdw*yj
14408           ggg(3)=facvdw*zj
14409           do k=1,3
14410             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14411             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14412           enddo
14413 #endif
14414 !
14415 ! Angular part
14416 !
14417           ecosa=2.0D0*fac3*fac1+fac4
14418           fac4=-3.0D0*fac4
14419           fac3=-6.0D0*fac3
14420           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14421           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14422           do k=1,3
14423             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14424             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14425           enddo
14426 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14427 !d   &          (dcosg(k),k=1,3)
14428           do k=1,3
14429             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14430           enddo
14431 !          do k=1,3
14432 !            ghalf=0.5D0*ggg(k)
14433 !            gelc(k,i)=gelc(k,i)+ghalf
14434 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14435 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14436 !            gelc(k,j)=gelc(k,j)+ghalf
14437 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14438 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14439 !          enddo
14440 !grad          do k=i+1,j-1
14441 !grad            do l=1,3
14442 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14443 !grad            enddo
14444 !grad          enddo
14445           do k=1,3
14446             gelc(k,i)=gelc(k,i) &
14447                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14448                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14449                      *sss_ele_cut
14450             gelc(k,j)=gelc(k,j) &
14451                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14452                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14453                      *sss_ele_cut
14454             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14455             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14456           enddo
14457           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14458               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14459               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14460 !
14461 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14462 !   energy of a peptide unit is assumed in the form of a second-order
14463 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14464 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14465 !   are computed for EVERY pair of non-contiguous peptide groups.
14466 !
14467           if (j.lt.nres-1) then
14468             j1=j+1
14469             j2=j-1
14470           else
14471             j1=j-1
14472             j2=j-2
14473           endif
14474           kkk=0
14475           do k=1,2
14476             do l=1,2
14477               kkk=kkk+1
14478               muij(kkk)=mu(k,i)*mu(l,j)
14479             enddo
14480           enddo
14481 !d         write (iout,*) 'EELEC: i',i,' j',j
14482 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14483 !d          write(iout,*) 'muij',muij
14484           ury=scalar(uy(1,i),erij)
14485           urz=scalar(uz(1,i),erij)
14486           vry=scalar(uy(1,j),erij)
14487           vrz=scalar(uz(1,j),erij)
14488           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14489           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14490           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14491           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14492           fac=dsqrt(-ael6i)*r3ij
14493           a22=a22*fac
14494           a23=a23*fac
14495           a32=a32*fac
14496           a33=a33*fac
14497 !d          write (iout,'(4i5,4f10.5)')
14498 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14499 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14500 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14501 !d     &      uy(:,j),uz(:,j)
14502 !d          write (iout,'(4f10.5)')
14503 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14504 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14505 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14506 !d           write (iout,'(9f10.5/)')
14507 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14508 ! Derivatives of the elements of A in virtual-bond vectors
14509           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14510           do k=1,3
14511             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14512             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14513             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14514             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14515             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14516             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14517             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14518             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14519             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14520             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14521             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14522             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14523           enddo
14524 ! Compute radial contributions to the gradient
14525           facr=-3.0d0*rrmij
14526           a22der=a22*facr
14527           a23der=a23*facr
14528           a32der=a32*facr
14529           a33der=a33*facr
14530           agg(1,1)=a22der*xj
14531           agg(2,1)=a22der*yj
14532           agg(3,1)=a22der*zj
14533           agg(1,2)=a23der*xj
14534           agg(2,2)=a23der*yj
14535           agg(3,2)=a23der*zj
14536           agg(1,3)=a32der*xj
14537           agg(2,3)=a32der*yj
14538           agg(3,3)=a32der*zj
14539           agg(1,4)=a33der*xj
14540           agg(2,4)=a33der*yj
14541           agg(3,4)=a33der*zj
14542 ! Add the contributions coming from er
14543           fac3=-3.0d0*fac
14544           do k=1,3
14545             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14546             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14547             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14548             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14549           enddo
14550           do k=1,3
14551 ! Derivatives in DC(i)
14552 !grad            ghalf1=0.5d0*agg(k,1)
14553 !grad            ghalf2=0.5d0*agg(k,2)
14554 !grad            ghalf3=0.5d0*agg(k,3)
14555 !grad            ghalf4=0.5d0*agg(k,4)
14556             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14557             -3.0d0*uryg(k,2)*vry)!+ghalf1
14558             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14559             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14560             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14561             -3.0d0*urzg(k,2)*vry)!+ghalf3
14562             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14563             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14564 ! Derivatives in DC(i+1)
14565             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14566             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14567             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14568             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14569             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14570             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14571             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14572             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14573 ! Derivatives in DC(j)
14574             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14575             -3.0d0*vryg(k,2)*ury)!+ghalf1
14576             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14577             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14578             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14579             -3.0d0*vryg(k,2)*urz)!+ghalf3
14580             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14581             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14582 ! Derivatives in DC(j+1) or DC(nres-1)
14583             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14584             -3.0d0*vryg(k,3)*ury)
14585             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14586             -3.0d0*vrzg(k,3)*ury)
14587             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14588             -3.0d0*vryg(k,3)*urz)
14589             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14590             -3.0d0*vrzg(k,3)*urz)
14591 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14592 !grad              do l=1,4
14593 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14594 !grad              enddo
14595 !grad            endif
14596           enddo
14597           acipa(1,1)=a22
14598           acipa(1,2)=a23
14599           acipa(2,1)=a32
14600           acipa(2,2)=a33
14601           a22=-a22
14602           a23=-a23
14603           do l=1,2
14604             do k=1,3
14605               agg(k,l)=-agg(k,l)
14606               aggi(k,l)=-aggi(k,l)
14607               aggi1(k,l)=-aggi1(k,l)
14608               aggj(k,l)=-aggj(k,l)
14609               aggj1(k,l)=-aggj1(k,l)
14610             enddo
14611           enddo
14612           if (j.lt.nres-1) then
14613             a22=-a22
14614             a32=-a32
14615             do l=1,3,2
14616               do k=1,3
14617                 agg(k,l)=-agg(k,l)
14618                 aggi(k,l)=-aggi(k,l)
14619                 aggi1(k,l)=-aggi1(k,l)
14620                 aggj(k,l)=-aggj(k,l)
14621                 aggj1(k,l)=-aggj1(k,l)
14622               enddo
14623             enddo
14624           else
14625             a22=-a22
14626             a23=-a23
14627             a32=-a32
14628             a33=-a33
14629             do l=1,4
14630               do k=1,3
14631                 agg(k,l)=-agg(k,l)
14632                 aggi(k,l)=-aggi(k,l)
14633                 aggi1(k,l)=-aggi1(k,l)
14634                 aggj(k,l)=-aggj(k,l)
14635                 aggj1(k,l)=-aggj1(k,l)
14636               enddo
14637             enddo
14638           endif
14639           ENDIF ! WCORR
14640           IF (wel_loc.gt.0.0d0) THEN
14641 ! Contribution to the local-electrostatic energy coming from the i-j pair
14642           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14643            +a33*muij(4)
14644 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14645
14646           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14647                   'eelloc',i,j,eel_loc_ij
14648 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14649
14650           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14651 ! Partial derivatives in virtual-bond dihedral angles gamma
14652           if (i.gt.1) &
14653           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14654                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14655                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14656                  *sss_ele_cut
14657           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14658                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14659                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14660                  *sss_ele_cut
14661            xtemp(1)=xj
14662            xtemp(2)=yj
14663            xtemp(3)=zj
14664
14665 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14666           do l=1,3
14667             ggg(l)=(agg(l,1)*muij(1)+ &
14668                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14669             *sss_ele_cut &
14670              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14671
14672             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14673             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14674 !grad            ghalf=0.5d0*ggg(l)
14675 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14676 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14677           enddo
14678 !grad          do k=i+1,j2
14679 !grad            do l=1,3
14680 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14681 !grad            enddo
14682 !grad          enddo
14683 ! Remaining derivatives of eello
14684           do l=1,3
14685             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14686                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14687             *sss_ele_cut
14688
14689             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14690                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14691             *sss_ele_cut
14692
14693             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14694                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14695             *sss_ele_cut
14696
14697             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14698                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14699             *sss_ele_cut
14700
14701           enddo
14702           ENDIF
14703 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14704 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14705           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14706              .and. num_conti.le.maxconts) then
14707 !            write (iout,*) i,j," entered corr"
14708 !
14709 ! Calculate the contact function. The ith column of the array JCONT will
14710 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14711 ! greater than I). The arrays FACONT and GACONT will contain the values of
14712 ! the contact function and its derivative.
14713 !           r0ij=1.02D0*rpp(iteli,itelj)
14714 !           r0ij=1.11D0*rpp(iteli,itelj)
14715             r0ij=2.20D0*rpp(iteli,itelj)
14716 !           r0ij=1.55D0*rpp(iteli,itelj)
14717             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14718 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14719             if (fcont.gt.0.0D0) then
14720               num_conti=num_conti+1
14721               if (num_conti.gt.maxconts) then
14722 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14723                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14724                                ' will skip next contacts for this conf.',num_conti
14725               else
14726                 jcont_hb(num_conti,i)=j
14727 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14728 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14729                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14730                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14731 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14732 !  terms.
14733                 d_cont(num_conti,i)=rij
14734 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14735 !     --- Electrostatic-interaction matrix ---
14736                 a_chuj(1,1,num_conti,i)=a22
14737                 a_chuj(1,2,num_conti,i)=a23
14738                 a_chuj(2,1,num_conti,i)=a32
14739                 a_chuj(2,2,num_conti,i)=a33
14740 !     --- Gradient of rij
14741                 do kkk=1,3
14742                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14743                 enddo
14744                 kkll=0
14745                 do k=1,2
14746                   do l=1,2
14747                     kkll=kkll+1
14748                     do m=1,3
14749                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14750                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14751                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14752                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14753                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14754                     enddo
14755                   enddo
14756                 enddo
14757                 ENDIF
14758                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14759 ! Calculate contact energies
14760                 cosa4=4.0D0*cosa
14761                 wij=cosa-3.0D0*cosb*cosg
14762                 cosbg1=cosb+cosg
14763                 cosbg2=cosb-cosg
14764 !               fac3=dsqrt(-ael6i)/r0ij**3
14765                 fac3=dsqrt(-ael6i)*r3ij
14766 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14767                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14768                 if (ees0tmp.gt.0) then
14769                   ees0pij=dsqrt(ees0tmp)
14770                 else
14771                   ees0pij=0
14772                 endif
14773 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14774                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14775                 if (ees0tmp.gt.0) then
14776                   ees0mij=dsqrt(ees0tmp)
14777                 else
14778                   ees0mij=0
14779                 endif
14780 !               ees0mij=0.0D0
14781                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14782                      *sss_ele_cut
14783
14784                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14785                      *sss_ele_cut
14786
14787 ! Diagnostics. Comment out or remove after debugging!
14788 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14789 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14790 !               ees0m(num_conti,i)=0.0D0
14791 ! End diagnostics.
14792 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14793 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14794 ! Angular derivatives of the contact function
14795                 ees0pij1=fac3/ees0pij
14796                 ees0mij1=fac3/ees0mij
14797                 fac3p=-3.0D0*fac3*rrmij
14798                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14799                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14800 !               ees0mij1=0.0D0
14801                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14802                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14803                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14804                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14805                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14806                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14807                 ecosap=ecosa1+ecosa2
14808                 ecosbp=ecosb1+ecosb2
14809                 ecosgp=ecosg1+ecosg2
14810                 ecosam=ecosa1-ecosa2
14811                 ecosbm=ecosb1-ecosb2
14812                 ecosgm=ecosg1-ecosg2
14813 ! Diagnostics
14814 !               ecosap=ecosa1
14815 !               ecosbp=ecosb1
14816 !               ecosgp=ecosg1
14817 !               ecosam=0.0D0
14818 !               ecosbm=0.0D0
14819 !               ecosgm=0.0D0
14820 ! End diagnostics
14821                 facont_hb(num_conti,i)=fcont
14822                 fprimcont=fprimcont/rij
14823 !d              facont_hb(num_conti,i)=1.0D0
14824 ! Following line is for diagnostics.
14825 !d              fprimcont=0.0D0
14826                 do k=1,3
14827                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14828                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14829                 enddo
14830                 do k=1,3
14831                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14832                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14833                 enddo
14834 !                gggp(1)=gggp(1)+ees0pijp*xj
14835 !                gggp(2)=gggp(2)+ees0pijp*yj
14836 !                gggp(3)=gggp(3)+ees0pijp*zj
14837 !                gggm(1)=gggm(1)+ees0mijp*xj
14838 !                gggm(2)=gggm(2)+ees0mijp*yj
14839 !                gggm(3)=gggm(3)+ees0mijp*zj
14840                 gggp(1)=gggp(1)+ees0pijp*xj &
14841                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14842                 gggp(2)=gggp(2)+ees0pijp*yj &
14843                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14844                 gggp(3)=gggp(3)+ees0pijp*zj &
14845                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14846
14847                 gggm(1)=gggm(1)+ees0mijp*xj &
14848                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14849
14850                 gggm(2)=gggm(2)+ees0mijp*yj &
14851                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14852
14853                 gggm(3)=gggm(3)+ees0mijp*zj &
14854                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14855
14856 ! Derivatives due to the contact function
14857                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14858                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14859                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14860                 do k=1,3
14861 !
14862 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14863 !          following the change of gradient-summation algorithm.
14864 !
14865 !grad                  ghalfp=0.5D0*gggp(k)
14866 !grad                  ghalfm=0.5D0*gggm(k)
14867 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14868 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14869 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14870 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14871 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14872 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14873 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14874 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14875 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14876 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14877 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14878 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14879 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14880 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14881                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14882                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14883                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14884                      *sss_ele_cut
14885
14886                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14887                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14888                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14889                      *sss_ele_cut
14890
14891                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14892                      *sss_ele_cut
14893
14894                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14895                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14896                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14897                      *sss_ele_cut
14898
14899                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14900                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14901                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14902                      *sss_ele_cut
14903
14904                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14905                      *sss_ele_cut
14906
14907                 enddo
14908               ENDIF ! wcorr
14909               endif  ! num_conti.le.maxconts
14910             endif  ! fcont.gt.0
14911           endif    ! j.gt.i+1
14912           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14913             do k=1,4
14914               do l=1,3
14915                 ghalf=0.5d0*agg(l,k)
14916                 aggi(l,k)=aggi(l,k)+ghalf
14917                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14918                 aggj(l,k)=aggj(l,k)+ghalf
14919               enddo
14920             enddo
14921             if (j.eq.nres-1 .and. i.lt.j-2) then
14922               do k=1,4
14923                 do l=1,3
14924                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14925                 enddo
14926               enddo
14927             endif
14928           endif
14929  128      continue
14930 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14931       return
14932       end subroutine eelecij_scale
14933 !-----------------------------------------------------------------------------
14934       subroutine evdwpp_short(evdw1)
14935 !
14936 ! Compute Evdwpp
14937 !
14938 !      implicit real*8 (a-h,o-z)
14939 !      include 'DIMENSIONS'
14940 !      include 'COMMON.CONTROL'
14941 !      include 'COMMON.IOUNITS'
14942 !      include 'COMMON.GEO'
14943 !      include 'COMMON.VAR'
14944 !      include 'COMMON.LOCAL'
14945 !      include 'COMMON.CHAIN'
14946 !      include 'COMMON.DERIV'
14947 !      include 'COMMON.INTERACT'
14948 !      include 'COMMON.CONTACTS'
14949 !      include 'COMMON.TORSION'
14950 !      include 'COMMON.VECTORS'
14951 !      include 'COMMON.FFIELD'
14952       real(kind=8),dimension(3) :: ggg
14953 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14954 #ifdef MOMENT
14955       real(kind=8) :: scal_el=1.0d0
14956 #else
14957       real(kind=8) :: scal_el=0.5d0
14958 #endif
14959 !el local variables
14960       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14961       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14962       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14963                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14964                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14965       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14966                     dist_temp, dist_init,sss_grad
14967       integer xshift,yshift,zshift
14968
14969
14970       evdw1=0.0D0
14971 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14972 !     & " iatel_e_vdw",iatel_e_vdw
14973       call flush(iout)
14974       do i=iatel_s_vdw,iatel_e_vdw
14975         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14976         dxi=dc(1,i)
14977         dyi=dc(2,i)
14978         dzi=dc(3,i)
14979         dx_normi=dc_norm(1,i)
14980         dy_normi=dc_norm(2,i)
14981         dz_normi=dc_norm(3,i)
14982         xmedi=c(1,i)+0.5d0*dxi
14983         ymedi=c(2,i)+0.5d0*dyi
14984         zmedi=c(3,i)+0.5d0*dzi
14985           xmedi=dmod(xmedi,boxxsize)
14986           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14987           ymedi=dmod(ymedi,boxysize)
14988           if (ymedi.lt.0) ymedi=ymedi+boxysize
14989           zmedi=dmod(zmedi,boxzsize)
14990           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14991         num_conti=0
14992 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14993 !     &   ' ielend',ielend_vdw(i)
14994         call flush(iout)
14995         do j=ielstart_vdw(i),ielend_vdw(i)
14996           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14997 !el          ind=ind+1
14998           iteli=itel(i)
14999           itelj=itel(j)
15000           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15001           aaa=app(iteli,itelj)
15002           bbb=bpp(iteli,itelj)
15003           dxj=dc(1,j)
15004           dyj=dc(2,j)
15005           dzj=dc(3,j)
15006           dx_normj=dc_norm(1,j)
15007           dy_normj=dc_norm(2,j)
15008           dz_normj=dc_norm(3,j)
15009 !          xj=c(1,j)+0.5D0*dxj-xmedi
15010 !          yj=c(2,j)+0.5D0*dyj-ymedi
15011 !          zj=c(3,j)+0.5D0*dzj-zmedi
15012           xj=c(1,j)+0.5D0*dxj
15013           yj=c(2,j)+0.5D0*dyj
15014           zj=c(3,j)+0.5D0*dzj
15015           xj=mod(xj,boxxsize)
15016           if (xj.lt.0) xj=xj+boxxsize
15017           yj=mod(yj,boxysize)
15018           if (yj.lt.0) yj=yj+boxysize
15019           zj=mod(zj,boxzsize)
15020           if (zj.lt.0) zj=zj+boxzsize
15021       isubchap=0
15022       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15023       xj_safe=xj
15024       yj_safe=yj
15025       zj_safe=zj
15026       do xshift=-1,1
15027       do yshift=-1,1
15028       do zshift=-1,1
15029           xj=xj_safe+xshift*boxxsize
15030           yj=yj_safe+yshift*boxysize
15031           zj=zj_safe+zshift*boxzsize
15032           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15033           if(dist_temp.lt.dist_init) then
15034             dist_init=dist_temp
15035             xj_temp=xj
15036             yj_temp=yj
15037             zj_temp=zj
15038             isubchap=1
15039           endif
15040        enddo
15041        enddo
15042        enddo
15043        if (isubchap.eq.1) then
15044 !C          print *,i,j
15045           xj=xj_temp-xmedi
15046           yj=yj_temp-ymedi
15047           zj=zj_temp-zmedi
15048        else
15049           xj=xj_safe-xmedi
15050           yj=yj_safe-ymedi
15051           zj=zj_safe-zmedi
15052        endif
15053
15054           rij=xj*xj+yj*yj+zj*zj
15055           rrmij=1.0D0/rij
15056           rij=dsqrt(rij)
15057           sss=sscale(rij/rpp(iteli,itelj))
15058             sss_ele_cut=sscale_ele(rij)
15059             sss_ele_grad=sscagrad_ele(rij)
15060             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15061             if (sss_ele_cut.le.0.0) cycle
15062           if (sss.gt.0.0d0) then
15063             rmij=1.0D0/rij
15064             r3ij=rrmij*rmij
15065             r6ij=r3ij*r3ij
15066             ev1=aaa*r6ij*r6ij
15067 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15068             if (j.eq.i+2) ev1=scal_el*ev1
15069             ev2=bbb*r6ij
15070             evdwij=ev1+ev2
15071             if (energy_dec) then
15072               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15073             endif
15074             evdw1=evdw1+evdwij*sss*sss_ele_cut
15075 !
15076 ! Calculate contributions to the Cartesian gradient.
15077 !
15078             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15079 !            ggg(1)=facvdw*xj
15080 !            ggg(2)=facvdw*yj
15081 !            ggg(3)=facvdw*zj
15082           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15083           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15084           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15085           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15086           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15087           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15088
15089             do k=1,3
15090               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15091               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15092             enddo
15093           endif
15094         enddo ! j
15095       enddo   ! i
15096       return
15097       end subroutine evdwpp_short
15098 !-----------------------------------------------------------------------------
15099       subroutine escp_long(evdw2,evdw2_14)
15100 !
15101 ! This subroutine calculates the excluded-volume interaction energy between
15102 ! peptide-group centers and side chains and its gradient in virtual-bond and
15103 ! side-chain vectors.
15104 !
15105 !      implicit real*8 (a-h,o-z)
15106 !      include 'DIMENSIONS'
15107 !      include 'COMMON.GEO'
15108 !      include 'COMMON.VAR'
15109 !      include 'COMMON.LOCAL'
15110 !      include 'COMMON.CHAIN'
15111 !      include 'COMMON.DERIV'
15112 !      include 'COMMON.INTERACT'
15113 !      include 'COMMON.FFIELD'
15114 !      include 'COMMON.IOUNITS'
15115 !      include 'COMMON.CONTROL'
15116       real(kind=8),dimension(3) :: ggg
15117 !el local variables
15118       integer :: i,iint,j,k,iteli,itypj,subchap
15119       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15120       real(kind=8) :: evdw2,evdw2_14,evdwij
15121       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15122                     dist_temp, dist_init
15123
15124       evdw2=0.0D0
15125       evdw2_14=0.0d0
15126 !d    print '(a)','Enter ESCP'
15127 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15128       do i=iatscp_s,iatscp_e
15129         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15130         iteli=itel(i)
15131         xi=0.5D0*(c(1,i)+c(1,i+1))
15132         yi=0.5D0*(c(2,i)+c(2,i+1))
15133         zi=0.5D0*(c(3,i)+c(3,i+1))
15134           xi=mod(xi,boxxsize)
15135           if (xi.lt.0) xi=xi+boxxsize
15136           yi=mod(yi,boxysize)
15137           if (yi.lt.0) yi=yi+boxysize
15138           zi=mod(zi,boxzsize)
15139           if (zi.lt.0) zi=zi+boxzsize
15140
15141         do iint=1,nscp_gr(i)
15142
15143         do j=iscpstart(i,iint),iscpend(i,iint)
15144           itypj=itype(j,1)
15145           if (itypj.eq.ntyp1) cycle
15146 ! Uncomment following three lines for SC-p interactions
15147 !         xj=c(1,nres+j)-xi
15148 !         yj=c(2,nres+j)-yi
15149 !         zj=c(3,nres+j)-zi
15150 ! Uncomment following three lines for Ca-p interactions
15151           xj=c(1,j)
15152           yj=c(2,j)
15153           zj=c(3,j)
15154           xj=mod(xj,boxxsize)
15155           if (xj.lt.0) xj=xj+boxxsize
15156           yj=mod(yj,boxysize)
15157           if (yj.lt.0) yj=yj+boxysize
15158           zj=mod(zj,boxzsize)
15159           if (zj.lt.0) zj=zj+boxzsize
15160       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15161       xj_safe=xj
15162       yj_safe=yj
15163       zj_safe=zj
15164       subchap=0
15165       do xshift=-1,1
15166       do yshift=-1,1
15167       do zshift=-1,1
15168           xj=xj_safe+xshift*boxxsize
15169           yj=yj_safe+yshift*boxysize
15170           zj=zj_safe+zshift*boxzsize
15171           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15172           if(dist_temp.lt.dist_init) then
15173             dist_init=dist_temp
15174             xj_temp=xj
15175             yj_temp=yj
15176             zj_temp=zj
15177             subchap=1
15178           endif
15179        enddo
15180        enddo
15181        enddo
15182        if (subchap.eq.1) then
15183           xj=xj_temp-xi
15184           yj=yj_temp-yi
15185           zj=zj_temp-zi
15186        else
15187           xj=xj_safe-xi
15188           yj=yj_safe-yi
15189           zj=zj_safe-zi
15190        endif
15191           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15192
15193           rij=dsqrt(1.0d0/rrij)
15194             sss_ele_cut=sscale_ele(rij)
15195             sss_ele_grad=sscagrad_ele(rij)
15196 !            print *,sss_ele_cut,sss_ele_grad,&
15197 !            (rij),r_cut_ele,rlamb_ele
15198             if (sss_ele_cut.le.0.0) cycle
15199           sss=sscale((rij/rscp(itypj,iteli)))
15200           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15201           if (sss.lt.1.0d0) then
15202
15203             fac=rrij**expon2
15204             e1=fac*fac*aad(itypj,iteli)
15205             e2=fac*bad(itypj,iteli)
15206             if (iabs(j-i) .le. 2) then
15207               e1=scal14*e1
15208               e2=scal14*e2
15209               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15210             endif
15211             evdwij=e1+e2
15212             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15213             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15214                 'evdw2',i,j,sss,evdwij
15215 !
15216 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15217 !
15218             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15219             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15220             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15221             ggg(1)=xj*fac
15222             ggg(2)=yj*fac
15223             ggg(3)=zj*fac
15224 ! Uncomment following three lines for SC-p interactions
15225 !           do k=1,3
15226 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15227 !           enddo
15228 ! Uncomment following line for SC-p interactions
15229 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15230             do k=1,3
15231               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15232               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15233             enddo
15234           endif
15235         enddo
15236
15237         enddo ! iint
15238       enddo ! i
15239       do i=1,nct
15240         do j=1,3
15241           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15242           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15243           gradx_scp(j,i)=expon*gradx_scp(j,i)
15244         enddo
15245       enddo
15246 !******************************************************************************
15247 !
15248 !                              N O T E !!!
15249 !
15250 ! To save time the factor EXPON has been extracted from ALL components
15251 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15252 ! use!
15253 !
15254 !******************************************************************************
15255       return
15256       end subroutine escp_long
15257 !-----------------------------------------------------------------------------
15258       subroutine escp_short(evdw2,evdw2_14)
15259 !
15260 ! This subroutine calculates the excluded-volume interaction energy between
15261 ! peptide-group centers and side chains and its gradient in virtual-bond and
15262 ! side-chain vectors.
15263 !
15264 !      implicit real*8 (a-h,o-z)
15265 !      include 'DIMENSIONS'
15266 !      include 'COMMON.GEO'
15267 !      include 'COMMON.VAR'
15268 !      include 'COMMON.LOCAL'
15269 !      include 'COMMON.CHAIN'
15270 !      include 'COMMON.DERIV'
15271 !      include 'COMMON.INTERACT'
15272 !      include 'COMMON.FFIELD'
15273 !      include 'COMMON.IOUNITS'
15274 !      include 'COMMON.CONTROL'
15275       real(kind=8),dimension(3) :: ggg
15276 !el local variables
15277       integer :: i,iint,j,k,iteli,itypj,subchap
15278       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15279       real(kind=8) :: evdw2,evdw2_14,evdwij
15280       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15281                     dist_temp, dist_init
15282
15283       evdw2=0.0D0
15284       evdw2_14=0.0d0
15285 !d    print '(a)','Enter ESCP'
15286 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15287       do i=iatscp_s,iatscp_e
15288         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15289         iteli=itel(i)
15290         xi=0.5D0*(c(1,i)+c(1,i+1))
15291         yi=0.5D0*(c(2,i)+c(2,i+1))
15292         zi=0.5D0*(c(3,i)+c(3,i+1))
15293           xi=mod(xi,boxxsize)
15294           if (xi.lt.0) xi=xi+boxxsize
15295           yi=mod(yi,boxysize)
15296           if (yi.lt.0) yi=yi+boxysize
15297           zi=mod(zi,boxzsize)
15298           if (zi.lt.0) zi=zi+boxzsize
15299
15300         do iint=1,nscp_gr(i)
15301
15302         do j=iscpstart(i,iint),iscpend(i,iint)
15303           itypj=itype(j,1)
15304           if (itypj.eq.ntyp1) cycle
15305 ! Uncomment following three lines for SC-p interactions
15306 !         xj=c(1,nres+j)-xi
15307 !         yj=c(2,nres+j)-yi
15308 !         zj=c(3,nres+j)-zi
15309 ! Uncomment following three lines for Ca-p interactions
15310 !          xj=c(1,j)-xi
15311 !          yj=c(2,j)-yi
15312 !          zj=c(3,j)-zi
15313           xj=c(1,j)
15314           yj=c(2,j)
15315           zj=c(3,j)
15316           xj=mod(xj,boxxsize)
15317           if (xj.lt.0) xj=xj+boxxsize
15318           yj=mod(yj,boxysize)
15319           if (yj.lt.0) yj=yj+boxysize
15320           zj=mod(zj,boxzsize)
15321           if (zj.lt.0) zj=zj+boxzsize
15322       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15323       xj_safe=xj
15324       yj_safe=yj
15325       zj_safe=zj
15326       subchap=0
15327       do xshift=-1,1
15328       do yshift=-1,1
15329       do zshift=-1,1
15330           xj=xj_safe+xshift*boxxsize
15331           yj=yj_safe+yshift*boxysize
15332           zj=zj_safe+zshift*boxzsize
15333           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15334           if(dist_temp.lt.dist_init) then
15335             dist_init=dist_temp
15336             xj_temp=xj
15337             yj_temp=yj
15338             zj_temp=zj
15339             subchap=1
15340           endif
15341        enddo
15342        enddo
15343        enddo
15344        if (subchap.eq.1) then
15345           xj=xj_temp-xi
15346           yj=yj_temp-yi
15347           zj=zj_temp-zi
15348        else
15349           xj=xj_safe-xi
15350           yj=yj_safe-yi
15351           zj=zj_safe-zi
15352        endif
15353
15354           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15355           rij=dsqrt(1.0d0/rrij)
15356             sss_ele_cut=sscale_ele(rij)
15357             sss_ele_grad=sscagrad_ele(rij)
15358 !            print *,sss_ele_cut,sss_ele_grad,&
15359 !            (rij),r_cut_ele,rlamb_ele
15360             if (sss_ele_cut.le.0.0) cycle
15361           sss=sscale(rij/rscp(itypj,iteli))
15362           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15363           if (sss.gt.0.0d0) then
15364
15365             fac=rrij**expon2
15366             e1=fac*fac*aad(itypj,iteli)
15367             e2=fac*bad(itypj,iteli)
15368             if (iabs(j-i) .le. 2) then
15369               e1=scal14*e1
15370               e2=scal14*e2
15371               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15372             endif
15373             evdwij=e1+e2
15374             evdw2=evdw2+evdwij*sss*sss_ele_cut
15375             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15376                 'evdw2',i,j,sss,evdwij
15377 !
15378 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15379 !
15380             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15381             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15382             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15383
15384             ggg(1)=xj*fac
15385             ggg(2)=yj*fac
15386             ggg(3)=zj*fac
15387 ! Uncomment following three lines for SC-p interactions
15388 !           do k=1,3
15389 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15390 !           enddo
15391 ! Uncomment following line for SC-p interactions
15392 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15393             do k=1,3
15394               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15395               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15396             enddo
15397           endif
15398         enddo
15399
15400         enddo ! iint
15401       enddo ! i
15402       do i=1,nct
15403         do j=1,3
15404           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15405           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15406           gradx_scp(j,i)=expon*gradx_scp(j,i)
15407         enddo
15408       enddo
15409 !******************************************************************************
15410 !
15411 !                              N O T E !!!
15412 !
15413 ! To save time the factor EXPON has been extracted from ALL components
15414 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15415 ! use!
15416 !
15417 !******************************************************************************
15418       return
15419       end subroutine escp_short
15420 !-----------------------------------------------------------------------------
15421 ! energy_p_new-sep_barrier.F
15422 !-----------------------------------------------------------------------------
15423       subroutine sc_grad_scale(scalfac)
15424 !      implicit real*8 (a-h,o-z)
15425       use calc_data
15426 !      include 'DIMENSIONS'
15427 !      include 'COMMON.CHAIN'
15428 !      include 'COMMON.DERIV'
15429 !      include 'COMMON.CALC'
15430 !      include 'COMMON.IOUNITS'
15431       real(kind=8),dimension(3) :: dcosom1,dcosom2
15432       real(kind=8) :: scalfac
15433 !el local variables
15434 !      integer :: i,j,k,l
15435
15436       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15437       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15438       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15439            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15440 ! diagnostics only
15441 !      eom1=0.0d0
15442 !      eom2=0.0d0
15443 !      eom12=evdwij*eps1_om12
15444 ! end diagnostics
15445 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15446 !     &  " sigder",sigder
15447 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15448 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15449       do k=1,3
15450         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15451         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15452       enddo
15453       do k=1,3
15454         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15455          *sss_ele_cut
15456       enddo
15457 !      write (iout,*) "gg",(gg(k),k=1,3)
15458       do k=1,3
15459         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15460                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15461                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15462                  *sss_ele_cut
15463         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15464                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15465                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15466          *sss_ele_cut
15467 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15468 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15469 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15470 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15471       enddo
15472 !
15473 ! Calculate the components of the gradient in DC and X
15474 !
15475       do l=1,3
15476         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15477         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15478       enddo
15479       return
15480       end subroutine sc_grad_scale
15481 !-----------------------------------------------------------------------------
15482 ! energy_split-sep.F
15483 !-----------------------------------------------------------------------------
15484       subroutine etotal_long(energia)
15485 !
15486 ! Compute the long-range slow-varying contributions to the energy
15487 !
15488 !      implicit real*8 (a-h,o-z)
15489 !      include 'DIMENSIONS'
15490       use MD_data, only: totT,usampl,eq_time
15491 #ifndef ISNAN
15492       external proc_proc
15493 #ifdef WINPGI
15494 !MS$ATTRIBUTES C ::  proc_proc
15495 #endif
15496 #endif
15497 #ifdef MPI
15498       include "mpif.h"
15499       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15500 #endif
15501 !      include 'COMMON.SETUP'
15502 !      include 'COMMON.IOUNITS'
15503 !      include 'COMMON.FFIELD'
15504 !      include 'COMMON.DERIV'
15505 !      include 'COMMON.INTERACT'
15506 !      include 'COMMON.SBRIDGE'
15507 !      include 'COMMON.CHAIN'
15508 !      include 'COMMON.VAR'
15509 !      include 'COMMON.LOCAL'
15510 !      include 'COMMON.MD'
15511       real(kind=8),dimension(0:n_ene) :: energia
15512 !el local variables
15513       integer :: i,n_corr,n_corr1,ierror,ierr
15514       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15515                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15516                   ecorr,ecorr5,ecorr6,eturn6,time00
15517 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15518 !elwrite(iout,*)"in etotal long"
15519
15520       if (modecalc.eq.12.or.modecalc.eq.14) then
15521 #ifdef MPI
15522 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15523 #else
15524         call int_from_cart1(.false.)
15525 #endif
15526       endif
15527 !elwrite(iout,*)"in etotal long"
15528
15529 #ifdef MPI
15530 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15531 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15532       call flush(iout)
15533       if (nfgtasks.gt.1) then
15534         time00=MPI_Wtime()
15535 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15536         if (fg_rank.eq.0) then
15537           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15538 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15539 !          call flush(iout)
15540 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15541 ! FG slaves as WEIGHTS array.
15542           weights_(1)=wsc
15543           weights_(2)=wscp
15544           weights_(3)=welec
15545           weights_(4)=wcorr
15546           weights_(5)=wcorr5
15547           weights_(6)=wcorr6
15548           weights_(7)=wel_loc
15549           weights_(8)=wturn3
15550           weights_(9)=wturn4
15551           weights_(10)=wturn6
15552           weights_(11)=wang
15553           weights_(12)=wscloc
15554           weights_(13)=wtor
15555           weights_(14)=wtor_d
15556           weights_(15)=wstrain
15557           weights_(16)=wvdwpp
15558           weights_(17)=wbond
15559           weights_(18)=scal14
15560           weights_(21)=wsccor
15561 ! FG Master broadcasts the WEIGHTS_ array
15562           call MPI_Bcast(weights_(1),n_ene,&
15563               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15564         else
15565 ! FG slaves receive the WEIGHTS array
15566           call MPI_Bcast(weights(1),n_ene,&
15567               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15568           wsc=weights(1)
15569           wscp=weights(2)
15570           welec=weights(3)
15571           wcorr=weights(4)
15572           wcorr5=weights(5)
15573           wcorr6=weights(6)
15574           wel_loc=weights(7)
15575           wturn3=weights(8)
15576           wturn4=weights(9)
15577           wturn6=weights(10)
15578           wang=weights(11)
15579           wscloc=weights(12)
15580           wtor=weights(13)
15581           wtor_d=weights(14)
15582           wstrain=weights(15)
15583           wvdwpp=weights(16)
15584           wbond=weights(17)
15585           scal14=weights(18)
15586           wsccor=weights(21)
15587         endif
15588         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15589           king,FG_COMM,IERR)
15590          time_Bcast=time_Bcast+MPI_Wtime()-time00
15591          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15592 !        call chainbuild_cart
15593 !        call int_from_cart1(.false.)
15594       endif
15595 !      write (iout,*) 'Processor',myrank,
15596 !     &  ' calling etotal_short ipot=',ipot
15597 !      call flush(iout)
15598 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15599 #endif
15600 !d    print *,'nnt=',nnt,' nct=',nct
15601 !
15602 !elwrite(iout,*)"in etotal long"
15603 ! Compute the side-chain and electrostatic interaction energy
15604 !
15605       goto (101,102,103,104,105,106) ipot
15606 ! Lennard-Jones potential.
15607   101 call elj_long(evdw)
15608 !d    print '(a)','Exit ELJ'
15609       goto 107
15610 ! Lennard-Jones-Kihara potential (shifted).
15611   102 call eljk_long(evdw)
15612       goto 107
15613 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15614   103 call ebp_long(evdw)
15615       goto 107
15616 ! Gay-Berne potential (shifted LJ, angular dependence).
15617   104 call egb_long(evdw)
15618       goto 107
15619 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15620   105 call egbv_long(evdw)
15621       goto 107
15622 ! Soft-sphere potential
15623   106 call e_softsphere(evdw)
15624 !
15625 ! Calculate electrostatic (H-bonding) energy of the main chain.
15626 !
15627   107 continue
15628       call vec_and_deriv
15629       if (ipot.lt.6) then
15630 #ifdef SPLITELE
15631          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15632              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15633              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15634              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15635 #else
15636          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15637              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15638              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15639              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15640 #endif
15641            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15642          else
15643             ees=0
15644             evdw1=0
15645             eel_loc=0
15646             eello_turn3=0
15647             eello_turn4=0
15648          endif
15649       else
15650 !        write (iout,*) "Soft-spheer ELEC potential"
15651         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15652          eello_turn4)
15653       endif
15654 !
15655 ! Calculate excluded-volume interaction energy between peptide groups
15656 ! and side chains.
15657 !
15658       if (ipot.lt.6) then
15659        if(wscp.gt.0d0) then
15660         call escp_long(evdw2,evdw2_14)
15661        else
15662         evdw2=0
15663         evdw2_14=0
15664        endif
15665       else
15666         call escp_soft_sphere(evdw2,evdw2_14)
15667       endif
15668 !
15669 ! 12/1/95 Multi-body terms
15670 !
15671       n_corr=0
15672       n_corr1=0
15673       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15674           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15675          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15676 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15677 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15678       else
15679          ecorr=0.0d0
15680          ecorr5=0.0d0
15681          ecorr6=0.0d0
15682          eturn6=0.0d0
15683       endif
15684       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15685          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15686       endif
15687 !
15688 ! If performing constraint dynamics, call the constraint energy
15689 !  after the equilibration time
15690       if(usampl.and.totT.gt.eq_time) then
15691          call EconstrQ
15692          call Econstr_back
15693       else
15694          Uconst=0.0d0
15695          Uconst_back=0.0d0
15696       endif
15697 !
15698 ! Sum the energies
15699 !
15700       do i=1,n_ene
15701         energia(i)=0.0d0
15702       enddo
15703       energia(1)=evdw
15704 #ifdef SCP14
15705       energia(2)=evdw2-evdw2_14
15706       energia(18)=evdw2_14
15707 #else
15708       energia(2)=evdw2
15709       energia(18)=0.0d0
15710 #endif
15711 #ifdef SPLITELE
15712       energia(3)=ees
15713       energia(16)=evdw1
15714 #else
15715       energia(3)=ees+evdw1
15716       energia(16)=0.0d0
15717 #endif
15718       energia(4)=ecorr
15719       energia(5)=ecorr5
15720       energia(6)=ecorr6
15721       energia(7)=eel_loc
15722       energia(8)=eello_turn3
15723       energia(9)=eello_turn4
15724       energia(10)=eturn6
15725       energia(20)=Uconst+Uconst_back
15726       call sum_energy(energia,.true.)
15727 !      write (iout,*) "Exit ETOTAL_LONG"
15728       call flush(iout)
15729       return
15730       end subroutine etotal_long
15731 !-----------------------------------------------------------------------------
15732       subroutine etotal_short(energia)
15733 !
15734 ! Compute the short-range fast-varying contributions to the energy
15735 !
15736 !      implicit real*8 (a-h,o-z)
15737 !      include 'DIMENSIONS'
15738 #ifndef ISNAN
15739       external proc_proc
15740 #ifdef WINPGI
15741 !MS$ATTRIBUTES C ::  proc_proc
15742 #endif
15743 #endif
15744 #ifdef MPI
15745       include "mpif.h"
15746       integer :: ierror,ierr
15747       real(kind=8),dimension(n_ene) :: weights_
15748       real(kind=8) :: time00
15749 #endif
15750 !      include 'COMMON.SETUP'
15751 !      include 'COMMON.IOUNITS'
15752 !      include 'COMMON.FFIELD'
15753 !      include 'COMMON.DERIV'
15754 !      include 'COMMON.INTERACT'
15755 !      include 'COMMON.SBRIDGE'
15756 !      include 'COMMON.CHAIN'
15757 !      include 'COMMON.VAR'
15758 !      include 'COMMON.LOCAL'
15759       real(kind=8),dimension(0:n_ene) :: energia
15760 !el local variables
15761       integer :: i,nres6
15762       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15763       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15764       nres6=6*nres
15765
15766 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15767 !      call flush(iout)
15768       if (modecalc.eq.12.or.modecalc.eq.14) then
15769 #ifdef MPI
15770         if (fg_rank.eq.0) call int_from_cart1(.false.)
15771 #else
15772         call int_from_cart1(.false.)
15773 #endif
15774       endif
15775 #ifdef MPI
15776 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15777 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15778 !      call flush(iout)
15779       if (nfgtasks.gt.1) then
15780         time00=MPI_Wtime()
15781 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15782         if (fg_rank.eq.0) then
15783           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15784 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15785 !          call flush(iout)
15786 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15787 ! FG slaves as WEIGHTS array.
15788           weights_(1)=wsc
15789           weights_(2)=wscp
15790           weights_(3)=welec
15791           weights_(4)=wcorr
15792           weights_(5)=wcorr5
15793           weights_(6)=wcorr6
15794           weights_(7)=wel_loc
15795           weights_(8)=wturn3
15796           weights_(9)=wturn4
15797           weights_(10)=wturn6
15798           weights_(11)=wang
15799           weights_(12)=wscloc
15800           weights_(13)=wtor
15801           weights_(14)=wtor_d
15802           weights_(15)=wstrain
15803           weights_(16)=wvdwpp
15804           weights_(17)=wbond
15805           weights_(18)=scal14
15806           weights_(21)=wsccor
15807 ! FG Master broadcasts the WEIGHTS_ array
15808           call MPI_Bcast(weights_(1),n_ene,&
15809               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15810         else
15811 ! FG slaves receive the WEIGHTS array
15812           call MPI_Bcast(weights(1),n_ene,&
15813               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15814           wsc=weights(1)
15815           wscp=weights(2)
15816           welec=weights(3)
15817           wcorr=weights(4)
15818           wcorr5=weights(5)
15819           wcorr6=weights(6)
15820           wel_loc=weights(7)
15821           wturn3=weights(8)
15822           wturn4=weights(9)
15823           wturn6=weights(10)
15824           wang=weights(11)
15825           wscloc=weights(12)
15826           wtor=weights(13)
15827           wtor_d=weights(14)
15828           wstrain=weights(15)
15829           wvdwpp=weights(16)
15830           wbond=weights(17)
15831           scal14=weights(18)
15832           wsccor=weights(21)
15833         endif
15834 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15835         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15836           king,FG_COMM,IERR)
15837 !        write (iout,*) "Processor",myrank," BROADCAST c"
15838         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15839           king,FG_COMM,IERR)
15840 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15841         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15842           king,FG_COMM,IERR)
15843 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15844         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15845           king,FG_COMM,IERR)
15846 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15847         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15848           king,FG_COMM,IERR)
15849 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15850         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15851           king,FG_COMM,IERR)
15852 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15853         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15854           king,FG_COMM,IERR)
15855 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15856         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15857           king,FG_COMM,IERR)
15858 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15859         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15860           king,FG_COMM,IERR)
15861          time_Bcast=time_Bcast+MPI_Wtime()-time00
15862 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15863       endif
15864 !      write (iout,*) 'Processor',myrank,
15865 !     &  ' calling etotal_short ipot=',ipot
15866 !      call flush(iout)
15867 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15868 #endif
15869 !      call int_from_cart1(.false.)
15870 !
15871 ! Compute the side-chain and electrostatic interaction energy
15872 !
15873       goto (101,102,103,104,105,106) ipot
15874 ! Lennard-Jones potential.
15875   101 call elj_short(evdw)
15876 !d    print '(a)','Exit ELJ'
15877       goto 107
15878 ! Lennard-Jones-Kihara potential (shifted).
15879   102 call eljk_short(evdw)
15880       goto 107
15881 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15882   103 call ebp_short(evdw)
15883       goto 107
15884 ! Gay-Berne potential (shifted LJ, angular dependence).
15885   104 call egb_short(evdw)
15886       goto 107
15887 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15888   105 call egbv_short(evdw)
15889       goto 107
15890 ! Soft-sphere potential - already dealt with in the long-range part
15891   106 evdw=0.0d0
15892 !  106 call e_softsphere_short(evdw)
15893 !
15894 ! Calculate electrostatic (H-bonding) energy of the main chain.
15895 !
15896   107 continue
15897 !
15898 ! Calculate the short-range part of Evdwpp
15899 !
15900       call evdwpp_short(evdw1)
15901 !
15902 ! Calculate the short-range part of ESCp
15903 !
15904       if (ipot.lt.6) then
15905         call escp_short(evdw2,evdw2_14)
15906       endif
15907 !
15908 ! Calculate the bond-stretching energy
15909 !
15910       call ebond(estr)
15911 !
15912 ! Calculate the disulfide-bridge and other energy and the contributions
15913 ! from other distance constraints.
15914       call edis(ehpb)
15915 !
15916 ! Calculate the virtual-bond-angle energy.
15917 !
15918       call ebend(ebe,ethetacnstr)
15919 !
15920 ! Calculate the SC local energy.
15921 !
15922       call vec_and_deriv
15923       call esc(escloc)
15924 !
15925 ! Calculate the virtual-bond torsional energy.
15926 !
15927       call etor(etors,edihcnstr)
15928 !
15929 ! 6/23/01 Calculate double-torsional energy
15930 !
15931       call etor_d(etors_d)
15932 !
15933 ! 21/5/07 Calculate local sicdechain correlation energy
15934 !
15935       if (wsccor.gt.0.0d0) then
15936         call eback_sc_corr(esccor)
15937       else
15938         esccor=0.0d0
15939       endif
15940 !
15941 ! Put energy components into an array
15942 !
15943       do i=1,n_ene
15944         energia(i)=0.0d0
15945       enddo
15946       energia(1)=evdw
15947 #ifdef SCP14
15948       energia(2)=evdw2-evdw2_14
15949       energia(18)=evdw2_14
15950 #else
15951       energia(2)=evdw2
15952       energia(18)=0.0d0
15953 #endif
15954 #ifdef SPLITELE
15955       energia(16)=evdw1
15956 #else
15957       energia(3)=evdw1
15958 #endif
15959       energia(11)=ebe
15960       energia(12)=escloc
15961       energia(13)=etors
15962       energia(14)=etors_d
15963       energia(15)=ehpb
15964       energia(17)=estr
15965       energia(19)=edihcnstr
15966       energia(21)=esccor
15967 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15968       call flush(iout)
15969       call sum_energy(energia,.true.)
15970 !      write (iout,*) "Exit ETOTAL_SHORT"
15971       call flush(iout)
15972       return
15973       end subroutine etotal_short
15974 !-----------------------------------------------------------------------------
15975 ! gnmr1.f
15976 !-----------------------------------------------------------------------------
15977       real(kind=8) function gnmr1(y,ymin,ymax)
15978 !      implicit none
15979       real(kind=8) :: y,ymin,ymax
15980       real(kind=8) :: wykl=4.0d0
15981       if (y.lt.ymin) then
15982         gnmr1=(ymin-y)**wykl/wykl
15983       else if (y.gt.ymax) then
15984         gnmr1=(y-ymax)**wykl/wykl
15985       else
15986         gnmr1=0.0d0
15987       endif
15988       return
15989       end function gnmr1
15990 !-----------------------------------------------------------------------------
15991       real(kind=8) function gnmr1prim(y,ymin,ymax)
15992 !      implicit none
15993       real(kind=8) :: y,ymin,ymax
15994       real(kind=8) :: wykl=4.0d0
15995       if (y.lt.ymin) then
15996         gnmr1prim=-(ymin-y)**(wykl-1)
15997       else if (y.gt.ymax) then
15998         gnmr1prim=(y-ymax)**(wykl-1)
15999       else
16000         gnmr1prim=0.0d0
16001       endif
16002       return
16003       end function gnmr1prim
16004 !----------------------------------------------------------------------------
16005       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16006       real(kind=8) y,ymin,ymax,sigma
16007       real(kind=8) wykl /4.0d0/
16008       if (y.lt.ymin) then
16009         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16010       else if (y.gt.ymax) then
16011         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16012       else
16013         rlornmr1=0.0d0
16014       endif
16015       return
16016       end function rlornmr1
16017 !------------------------------------------------------------------------------
16018       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16019       real(kind=8) y,ymin,ymax,sigma
16020       real(kind=8) wykl /4.0d0/
16021       if (y.lt.ymin) then
16022         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16023         ((ymin-y)**wykl+sigma**wykl)**2
16024       else if (y.gt.ymax) then
16025         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16026         ((y-ymax)**wykl+sigma**wykl)**2
16027       else
16028         rlornmr1prim=0.0d0
16029       endif
16030       return
16031       end function rlornmr1prim
16032
16033       real(kind=8) function harmonic(y,ymax)
16034 !      implicit none
16035       real(kind=8) :: y,ymax
16036       real(kind=8) :: wykl=2.0d0
16037       harmonic=(y-ymax)**wykl
16038       return
16039       end function harmonic
16040 !-----------------------------------------------------------------------------
16041       real(kind=8) function harmonicprim(y,ymax)
16042       real(kind=8) :: y,ymin,ymax
16043       real(kind=8) :: wykl=2.0d0
16044       harmonicprim=(y-ymax)*wykl
16045       return
16046       end function harmonicprim
16047 !-----------------------------------------------------------------------------
16048 ! gradient_p.F
16049 !-----------------------------------------------------------------------------
16050       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16051
16052       use io_base, only:intout,briefout
16053 !      implicit real*8 (a-h,o-z)
16054 !      include 'DIMENSIONS'
16055 !      include 'COMMON.CHAIN'
16056 !      include 'COMMON.DERIV'
16057 !      include 'COMMON.VAR'
16058 !      include 'COMMON.INTERACT'
16059 !      include 'COMMON.FFIELD'
16060 !      include 'COMMON.MD'
16061 !      include 'COMMON.IOUNITS'
16062       real(kind=8),external :: ufparm
16063       integer :: uiparm(1)
16064       real(kind=8) :: urparm(1)
16065       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16066       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16067       integer :: n,nf,ind,ind1,i,k,j
16068 !
16069 ! This subroutine calculates total internal coordinate gradient.
16070 ! Depending on the number of function evaluations, either whole energy
16071 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16072 ! internal coordinates are reevaluated or only the cartesian-in-internal
16073 ! coordinate derivatives are evaluated. The subroutine was designed to work
16074 ! with SUMSL.
16075 !
16076 !
16077       icg=mod(nf,2)+1
16078
16079 !d      print *,'grad',nf,icg
16080       if (nf-nfl+1) 20,30,40
16081    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16082 !    write (iout,*) 'grad 20'
16083       if (nf.eq.0) return
16084       goto 40
16085    30 call var_to_geom(n,x)
16086       call chainbuild
16087 !    write (iout,*) 'grad 30'
16088 !
16089 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16090 !
16091    40 call cartder
16092 !     write (iout,*) 'grad 40'
16093 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16094 !
16095 ! Convert the Cartesian gradient into internal-coordinate gradient.
16096 !
16097       ind=0
16098       ind1=0
16099       do i=1,nres-2
16100       gthetai=0.0D0
16101       gphii=0.0D0
16102       do j=i+1,nres-1
16103           ind=ind+1
16104 !         ind=indmat(i,j)
16105 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16106         do k=1,3
16107             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16108           enddo
16109         do k=1,3
16110           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16111           enddo
16112         enddo
16113       do j=i+1,nres-1
16114           ind1=ind1+1
16115 !         ind1=indmat(i,j)
16116 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16117         do k=1,3
16118           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16119           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16120           enddo
16121         enddo
16122       if (i.gt.1) g(i-1)=gphii
16123       if (n.gt.nphi) g(nphi+i)=gthetai
16124       enddo
16125       if (n.le.nphi+ntheta) goto 10
16126       do i=2,nres-1
16127       if (itype(i,1).ne.10) then
16128           galphai=0.0D0
16129         gomegai=0.0D0
16130         do k=1,3
16131           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16132           enddo
16133         do k=1,3
16134           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16135           enddo
16136           g(ialph(i,1))=galphai
16137         g(ialph(i,1)+nside)=gomegai
16138         endif
16139       enddo
16140 !
16141 ! Add the components corresponding to local energy terms.
16142 !
16143    10 continue
16144       do i=1,nvar
16145 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16146         g(i)=g(i)+gloc(i,icg)
16147       enddo
16148 ! Uncomment following three lines for diagnostics.
16149 !d    call intout
16150 !elwrite(iout,*) "in gradient after calling intout"
16151 !d    call briefout(0,0.0d0)
16152 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16153       return
16154       end subroutine gradient
16155 !-----------------------------------------------------------------------------
16156       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16157
16158       use comm_chu
16159 !      implicit real*8 (a-h,o-z)
16160 !      include 'DIMENSIONS'
16161 !      include 'COMMON.DERIV'
16162 !      include 'COMMON.IOUNITS'
16163 !      include 'COMMON.GEO'
16164       integer :: n,nf
16165 !el      integer :: jjj
16166 !el      common /chuju/ jjj
16167       real(kind=8) :: energia(0:n_ene)
16168       integer :: uiparm(1)
16169       real(kind=8) :: urparm(1)
16170       real(kind=8) :: f
16171       real(kind=8),external :: ufparm
16172       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16173 !     if (jjj.gt.0) then
16174 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16175 !     endif
16176       nfl=nf
16177       icg=mod(nf,2)+1
16178 !d      print *,'func',nf,nfl,icg
16179       call var_to_geom(n,x)
16180       call zerograd
16181       call chainbuild
16182 !d    write (iout,*) 'ETOTAL called from FUNC'
16183       call etotal(energia)
16184       call sum_gradient
16185       f=energia(0)
16186 !     if (jjj.gt.0) then
16187 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16188 !       write (iout,*) 'f=',etot
16189 !       jjj=0
16190 !     endif
16191       return
16192       end subroutine func
16193 !-----------------------------------------------------------------------------
16194       subroutine cartgrad
16195 !      implicit real*8 (a-h,o-z)
16196 !      include 'DIMENSIONS'
16197       use energy_data
16198       use MD_data, only: totT,usampl,eq_time
16199 #ifdef MPI
16200       include 'mpif.h'
16201 #endif
16202 !      include 'COMMON.CHAIN'
16203 !      include 'COMMON.DERIV'
16204 !      include 'COMMON.VAR'
16205 !      include 'COMMON.INTERACT'
16206 !      include 'COMMON.FFIELD'
16207 !      include 'COMMON.MD'
16208 !      include 'COMMON.IOUNITS'
16209 !      include 'COMMON.TIME1'
16210 !
16211       integer :: i,j
16212
16213 ! This subrouting calculates total Cartesian coordinate gradient.
16214 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16215 !
16216 !el#define DEBUG
16217 #ifdef TIMING
16218       time00=MPI_Wtime()
16219 #endif
16220       icg=1
16221       call sum_gradient
16222 #ifdef TIMING
16223 #endif
16224 !el      write (iout,*) "After sum_gradient"
16225 #ifdef DEBUG
16226 !el      write (iout,*) "After sum_gradient"
16227       do i=1,nres-1
16228         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16229         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16230       enddo
16231 #endif
16232 ! If performing constraint dynamics, add the gradients of the constraint energy
16233       if(usampl.and.totT.gt.eq_time) then
16234          do i=1,nct
16235            do j=1,3
16236              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16237              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16238            enddo
16239          enddo
16240          do i=1,nres-3
16241            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16242          enddo
16243          do i=1,nres-2
16244            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16245          enddo
16246       endif
16247 !elwrite (iout,*) "After sum_gradient"
16248 #ifdef TIMING
16249       time01=MPI_Wtime()
16250 #endif
16251       call intcartderiv
16252 !elwrite (iout,*) "After sum_gradient"
16253 #ifdef TIMING
16254       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16255 #endif
16256 !     call checkintcartgrad
16257 !     write(iout,*) 'calling int_to_cart'
16258 #ifdef DEBUG
16259       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16260 #endif
16261       do i=0,nct
16262         do j=1,3
16263           gcart(j,i)=gradc(j,i,icg)
16264           gxcart(j,i)=gradx(j,i,icg)
16265 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16266         enddo
16267 #ifdef DEBUG
16268         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16269           (gxcart(j,i),j=1,3),gloc(i,icg)
16270 #endif
16271       enddo
16272 #ifdef TIMING
16273       time01=MPI_Wtime()
16274 #endif
16275 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16276       call int_to_cart
16277 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16278
16279 #ifdef TIMING
16280             time_inttocart=time_inttocart+MPI_Wtime()-time01
16281 #endif
16282 #ifdef DEBUG
16283             write (iout,*) "gcart and gxcart after int_to_cart"
16284             do i=0,nres-1
16285             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16286                 (gxcart(j,i),j=1,3)
16287             enddo
16288 #endif
16289 #ifdef CARGRAD
16290 #ifdef DEBUG
16291             write (iout,*) "CARGRAD"
16292 #endif
16293             do i=nres,0,-1
16294             do j=1,3
16295               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16296       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16297             enddo
16298       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16299       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16300             enddo
16301       ! Correction: dummy residues
16302             if (nnt.gt.1) then
16303               do j=1,3
16304       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16305                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16306               enddo
16307             endif
16308             if (nct.lt.nres) then
16309               do j=1,3
16310       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16311                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16312               enddo
16313             endif
16314 #endif
16315 #ifdef TIMING
16316             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16317 #endif
16318       !el#undef DEBUG
16319             return
16320             end subroutine cartgrad
16321       !-----------------------------------------------------------------------------
16322             subroutine zerograd
16323       !      implicit real*8 (a-h,o-z)
16324       !      include 'DIMENSIONS'
16325       !      include 'COMMON.DERIV'
16326       !      include 'COMMON.CHAIN'
16327       !      include 'COMMON.VAR'
16328       !      include 'COMMON.MD'
16329       !      include 'COMMON.SCCOR'
16330       !
16331       !el local variables
16332             integer :: i,j,intertyp,k
16333       ! Initialize Cartesian-coordinate gradient
16334       !
16335       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16336       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16337
16338       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16339       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16340       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16341       !      allocate(gradcorr_long(3,nres))
16342       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16343       !      allocate(gcorr6_turn_long(3,nres))
16344       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16345
16346       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16347
16348       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16349       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16350
16351       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16352       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16353
16354       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16355       !      allocate(gscloc(3,nres)) !(3,maxres)
16356       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16357
16358
16359
16360       !      common /deriv_scloc/
16361       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16362       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16363       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16364       !      common /mpgrad/
16365       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16366
16367
16368
16369       !          gradc(j,i,icg)=0.0d0
16370       !          gradx(j,i,icg)=0.0d0
16371
16372       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16373       !elwrite(iout,*) "icg",icg
16374             do i=-1,nres
16375             do j=1,3
16376               gvdwx(j,i)=0.0D0
16377               gradx_scp(j,i)=0.0D0
16378               gvdwc(j,i)=0.0D0
16379               gvdwc_scp(j,i)=0.0D0
16380               gvdwc_scpp(j,i)=0.0d0
16381               gelc(j,i)=0.0D0
16382               gelc_long(j,i)=0.0D0
16383               gradb(j,i)=0.0d0
16384               gradbx(j,i)=0.0d0
16385               gvdwpp(j,i)=0.0d0
16386               gel_loc(j,i)=0.0d0
16387               gel_loc_long(j,i)=0.0d0
16388               ghpbc(j,i)=0.0D0
16389               ghpbx(j,i)=0.0D0
16390               gcorr3_turn(j,i)=0.0d0
16391               gcorr4_turn(j,i)=0.0d0
16392               gradcorr(j,i)=0.0d0
16393               gradcorr_long(j,i)=0.0d0
16394               gradcorr5_long(j,i)=0.0d0
16395               gradcorr6_long(j,i)=0.0d0
16396               gcorr6_turn_long(j,i)=0.0d0
16397               gradcorr5(j,i)=0.0d0
16398               gradcorr6(j,i)=0.0d0
16399               gcorr6_turn(j,i)=0.0d0
16400               gsccorc(j,i)=0.0d0
16401               gsccorx(j,i)=0.0d0
16402               gradc(j,i,icg)=0.0d0
16403               gradx(j,i,icg)=0.0d0
16404               gscloc(j,i)=0.0d0
16405               gsclocx(j,i)=0.0d0
16406               gliptran(j,i)=0.0d0
16407               gliptranx(j,i)=0.0d0
16408               gliptranc(j,i)=0.0d0
16409               gshieldx(j,i)=0.0d0
16410               gshieldc(j,i)=0.0d0
16411               gshieldc_loc(j,i)=0.0d0
16412               gshieldx_ec(j,i)=0.0d0
16413               gshieldc_ec(j,i)=0.0d0
16414               gshieldc_loc_ec(j,i)=0.0d0
16415               gshieldx_t3(j,i)=0.0d0
16416               gshieldc_t3(j,i)=0.0d0
16417               gshieldc_loc_t3(j,i)=0.0d0
16418               gshieldx_t4(j,i)=0.0d0
16419               gshieldc_t4(j,i)=0.0d0
16420               gshieldc_loc_t4(j,i)=0.0d0
16421               gshieldx_ll(j,i)=0.0d0
16422               gshieldc_ll(j,i)=0.0d0
16423               gshieldc_loc_ll(j,i)=0.0d0
16424               gg_tube(j,i)=0.0d0
16425               gg_tube_sc(j,i)=0.0d0
16426               gradafm(j,i)=0.0d0
16427               gradb_nucl(j,i)=0.0d0
16428               gradbx_nucl(j,i)=0.0d0
16429               gvdwpp_nucl(j,i)=0.0d0
16430               gvdwpp(j,i)=0.0d0
16431               gelpp(j,i)=0.0d0
16432               gvdwpsb(j,i)=0.0d0
16433               gvdwpsb1(j,i)=0.0d0
16434               gvdwsbc(j,i)=0.0d0
16435               gvdwsbx(j,i)=0.0d0
16436               gelsbc(j,i)=0.0d0
16437               gradcorr_nucl(j,i)=0.0d0
16438               gradcorr3_nucl(j,i)=0.0d0
16439               gradxorr_nucl(j,i)=0.0d0
16440               gradxorr3_nucl(j,i)=0.0d0
16441               gelsbx(j,i)=0.0d0
16442               gsbloc(j,i)=0.0d0
16443               gsblocx(j,i)=0.0d0
16444               gradpepcat(j,i)=0.0d0
16445               gradpepcatx(j,i)=0.0d0
16446               gradcatcat(j,i)=0.0d0
16447               gvdwx_scbase(j,i)=0.0d0
16448               gvdwc_scbase(j,i)=0.0d0
16449               gvdwx_pepbase(j,i)=0.0d0
16450               gvdwc_pepbase(j,i)=0.0d0
16451               gvdwx_scpho(j,i)=0.0d0
16452               gvdwc_scpho(j,i)=0.0d0
16453               gvdwc_peppho(j,i)=0.0d0
16454             enddo
16455              enddo
16456             do i=0,nres
16457             do j=1,3
16458               do intertyp=1,3
16459                gloc_sc(intertyp,i,icg)=0.0d0
16460               enddo
16461             enddo
16462             enddo
16463             do i=1,nres
16464              do j=1,maxcontsshi
16465              shield_list(j,i)=0
16466             do k=1,3
16467       !C           print *,i,j,k
16468                grad_shield_side(k,j,i)=0.0d0
16469                grad_shield_loc(k,j,i)=0.0d0
16470              enddo
16471              enddo
16472              ishield_list(i)=0
16473             enddo
16474
16475       !
16476       ! Initialize the gradient of local energy terms.
16477       !
16478       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16479       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16480       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16481       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16482       !      allocate(gel_loc_turn3(nres))
16483       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16484       !      allocate(gsccor_loc(nres))      !(maxres)
16485
16486             do i=1,4*nres
16487             gloc(i,icg)=0.0D0
16488             enddo
16489             do i=1,nres
16490             gel_loc_loc(i)=0.0d0
16491             gcorr_loc(i)=0.0d0
16492             g_corr5_loc(i)=0.0d0
16493             g_corr6_loc(i)=0.0d0
16494             gel_loc_turn3(i)=0.0d0
16495             gel_loc_turn4(i)=0.0d0
16496             gel_loc_turn6(i)=0.0d0
16497             gsccor_loc(i)=0.0d0
16498             enddo
16499       ! initialize gcart and gxcart
16500       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16501             do i=0,nres
16502             do j=1,3
16503               gcart(j,i)=0.0d0
16504               gxcart(j,i)=0.0d0
16505             enddo
16506             enddo
16507             return
16508             end subroutine zerograd
16509       !-----------------------------------------------------------------------------
16510             real(kind=8) function fdum()
16511             fdum=0.0D0
16512             return
16513             end function fdum
16514       !-----------------------------------------------------------------------------
16515       ! intcartderiv.F
16516       !-----------------------------------------------------------------------------
16517             subroutine intcartderiv
16518       !      implicit real*8 (a-h,o-z)
16519       !      include 'DIMENSIONS'
16520 #ifdef MPI
16521             include 'mpif.h'
16522 #endif
16523       !      include 'COMMON.SETUP'
16524       !      include 'COMMON.CHAIN'
16525       !      include 'COMMON.VAR'
16526       !      include 'COMMON.GEO'
16527       !      include 'COMMON.INTERACT'
16528       !      include 'COMMON.DERIV'
16529       !      include 'COMMON.IOUNITS'
16530       !      include 'COMMON.LOCAL'
16531       !      include 'COMMON.SCCOR'
16532             real(kind=8) :: pi4,pi34
16533             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16534             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16535                       dcosomega,dsinomega !(3,3,maxres)
16536             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16537
16538             integer :: i,j,k
16539             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16540                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16541                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16542                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16543             integer :: nres2
16544             nres2=2*nres
16545
16546       !el from module energy-------------
16547       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16548       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16549       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16550
16551       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16552       !el      allocate(dsintau(3,3,3,0:nres2))
16553       !el      allocate(dtauangle(3,3,3,0:nres2))
16554       !el      allocate(domicron(3,2,2,0:nres2))
16555       !el      allocate(dcosomicron(3,2,2,0:nres2))
16556
16557
16558
16559 #if defined(MPI) && defined(PARINTDER)
16560             if (nfgtasks.gt.1 .and. me.eq.king) &
16561             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16562 #endif
16563             pi4 = 0.5d0*pipol
16564             pi34 = 3*pi4
16565
16566       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16567       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16568
16569       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16570             do i=1,nres
16571             do j=1,3
16572               dtheta(j,1,i)=0.0d0
16573               dtheta(j,2,i)=0.0d0
16574               dphi(j,1,i)=0.0d0
16575               dphi(j,2,i)=0.0d0
16576               dphi(j,3,i)=0.0d0
16577             enddo
16578             enddo
16579       ! Derivatives of theta's
16580 #if defined(MPI) && defined(PARINTDER)
16581       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16582             do i=max0(ithet_start-1,3),ithet_end
16583 #else
16584             do i=3,nres
16585 #endif
16586             cost=dcos(theta(i))
16587             sint=sqrt(1-cost*cost)
16588             do j=1,3
16589               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16590               vbld(i-1)
16591               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16592               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16593               vbld(i)
16594               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16595             enddo
16596             enddo
16597 #if defined(MPI) && defined(PARINTDER)
16598       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16599             do i=max0(ithet_start-1,3),ithet_end
16600 #else
16601             do i=3,nres
16602 #endif
16603             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16604             cost1=dcos(omicron(1,i))
16605             sint1=sqrt(1-cost1*cost1)
16606             cost2=dcos(omicron(2,i))
16607             sint2=sqrt(1-cost2*cost2)
16608              do j=1,3
16609       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16610               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16611               cost1*dc_norm(j,i-2))/ &
16612               vbld(i-1)
16613               domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16614               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16615               +cost1*(dc_norm(j,i-1+nres)))/ &
16616               vbld(i-1+nres)
16617               domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16618       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16619       !C Looks messy but better than if in loop
16620               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16621               +cost2*dc_norm(j,i-1))/ &
16622               vbld(i)
16623               domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16624               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16625                +cost2*(-dc_norm(j,i-1+nres)))/ &
16626               vbld(i-1+nres)
16627       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16628               domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16629             enddo
16630              endif
16631             enddo
16632       !elwrite(iout,*) "after vbld write"
16633       ! Derivatives of phi:
16634       ! If phi is 0 or 180 degrees, then the formulas
16635       ! have to be derived by power series expansion of the
16636       ! conventional formulas around 0 and 180.
16637 #ifdef PARINTDER
16638             do i=iphi1_start,iphi1_end
16639 #else
16640             do i=4,nres
16641 #endif
16642       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16643       ! the conventional case
16644             sint=dsin(theta(i))
16645             sint1=dsin(theta(i-1))
16646             sing=dsin(phi(i))
16647             cost=dcos(theta(i))
16648             cost1=dcos(theta(i-1))
16649             cosg=dcos(phi(i))
16650             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16651             fac0=1.0d0/(sint1*sint)
16652             fac1=cost*fac0
16653             fac2=cost1*fac0
16654             fac3=cosg*cost1/(sint1*sint1)
16655             fac4=cosg*cost/(sint*sint)
16656       !    Obtaining the gamma derivatives from sine derivative
16657              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16658                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16659                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16660              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16661              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16662              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16663              do j=1,3
16664                 ctgt=cost/sint
16665                 ctgt1=cost1/sint1
16666                 cosg_inv=1.0d0/cosg
16667                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16668                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16669                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16670                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16671                 dsinphi(j,2,i)= &
16672                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16673                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16674                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16675                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16676                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16677       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16678                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16679                 endif
16680       ! Bug fixed 3/24/05 (AL)
16681              enddo
16682       !   Obtaining the gamma derivatives from cosine derivative
16683             else
16684                do j=1,3
16685                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16686                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16687                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16688                dc_norm(j,i-3))/vbld(i-2)
16689                dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16690                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16691                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16692                dcostheta(j,1,i)
16693                dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16694                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16695                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16696                dc_norm(j,i-1))/vbld(i)
16697                dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16698                endif
16699              enddo
16700             endif
16701             enddo
16702       !alculate derivative of Tauangle
16703 #ifdef PARINTDER
16704             do i=itau_start,itau_end
16705 #else
16706             do i=3,nres
16707       !elwrite(iout,*) " vecpr",i,nres
16708 #endif
16709              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16710       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16711       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16712       !c dtauangle(j,intertyp,dervityp,residue number)
16713       !c INTERTYP=1 SC...Ca...Ca..Ca
16714       ! the conventional case
16715             sint=dsin(theta(i))
16716             sint1=dsin(omicron(2,i-1))
16717             sing=dsin(tauangle(1,i))
16718             cost=dcos(theta(i))
16719             cost1=dcos(omicron(2,i-1))
16720             cosg=dcos(tauangle(1,i))
16721       !elwrite(iout,*) " vecpr5",i,nres
16722             do j=1,3
16723       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16724       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16725             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16726       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16727             enddo
16728             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16729             fac0=1.0d0/(sint1*sint)
16730             fac1=cost*fac0
16731             fac2=cost1*fac0
16732             fac3=cosg*cost1/(sint1*sint1)
16733             fac4=cosg*cost/(sint*sint)
16734       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16735       !    Obtaining the gamma derivatives from sine derivative
16736              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16737                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16738                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16739              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16740              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16741              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16742             do j=1,3
16743                 ctgt=cost/sint
16744                 ctgt1=cost1/sint1
16745                 cosg_inv=1.0d0/cosg
16746                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16747              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16748              *vbld_inv(i-2+nres)
16749                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16750                 dsintau(j,1,2,i)= &
16751                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16752                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16753       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16754                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16755       ! Bug fixed 3/24/05 (AL)
16756                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16757                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16758       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16759                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16760              enddo
16761       !   Obtaining the gamma derivatives from cosine derivative
16762             else
16763                do j=1,3
16764                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16765                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16766                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16767                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16768                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16769                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16770                dcostheta(j,1,i)
16771                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16772                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16773                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16774                dc_norm(j,i-1))/vbld(i)
16775                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16776       !         write (iout,*) "else",i
16777              enddo
16778             endif
16779       !        do k=1,3
16780       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16781       !        enddo
16782             enddo
16783       !C Second case Ca...Ca...Ca...SC
16784 #ifdef PARINTDER
16785             do i=itau_start,itau_end
16786 #else
16787             do i=4,nres
16788 #endif
16789              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16790               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16791       ! the conventional case
16792             sint=dsin(omicron(1,i))
16793             sint1=dsin(theta(i-1))
16794             sing=dsin(tauangle(2,i))
16795             cost=dcos(omicron(1,i))
16796             cost1=dcos(theta(i-1))
16797             cosg=dcos(tauangle(2,i))
16798       !        do j=1,3
16799       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16800       !        enddo
16801             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16802             fac0=1.0d0/(sint1*sint)
16803             fac1=cost*fac0
16804             fac2=cost1*fac0
16805             fac3=cosg*cost1/(sint1*sint1)
16806             fac4=cosg*cost/(sint*sint)
16807       !    Obtaining the gamma derivatives from sine derivative
16808              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16809                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16810                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16811              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16812              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16813              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16814             do j=1,3
16815                 ctgt=cost/sint
16816                 ctgt1=cost1/sint1
16817                 cosg_inv=1.0d0/cosg
16818                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16819                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16820       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16821       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16822                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16823                 dsintau(j,2,2,i)= &
16824                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16825                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16826       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16827       !     & sing*ctgt*domicron(j,1,2,i),
16828       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16829                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16830       ! Bug fixed 3/24/05 (AL)
16831                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16832                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16833       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16834                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16835              enddo
16836       !   Obtaining the gamma derivatives from cosine derivative
16837             else
16838                do j=1,3
16839                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16840                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16841                dc_norm(j,i-3))/vbld(i-2)
16842                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16843                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16844                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16845                dcosomicron(j,1,1,i)
16846                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16847                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16848                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16849                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16850                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16851       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16852              enddo
16853             endif
16854             enddo
16855
16856       !CC third case SC...Ca...Ca...SC
16857 #ifdef PARINTDER
16858
16859             do i=itau_start,itau_end
16860 #else
16861             do i=3,nres
16862 #endif
16863       ! the conventional case
16864             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16865             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16866             sint=dsin(omicron(1,i))
16867             sint1=dsin(omicron(2,i-1))
16868             sing=dsin(tauangle(3,i))
16869             cost=dcos(omicron(1,i))
16870             cost1=dcos(omicron(2,i-1))
16871             cosg=dcos(tauangle(3,i))
16872             do j=1,3
16873             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16874       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16875             enddo
16876             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16877             fac0=1.0d0/(sint1*sint)
16878             fac1=cost*fac0
16879             fac2=cost1*fac0
16880             fac3=cosg*cost1/(sint1*sint1)
16881             fac4=cosg*cost/(sint*sint)
16882       !    Obtaining the gamma derivatives from sine derivative
16883              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16884                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16885                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16886              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16887              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16888              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16889             do j=1,3
16890                 ctgt=cost/sint
16891                 ctgt1=cost1/sint1
16892                 cosg_inv=1.0d0/cosg
16893                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16894                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16895                   *vbld_inv(i-2+nres)
16896                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16897                 dsintau(j,3,2,i)= &
16898                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16899                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16900                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16901       ! Bug fixed 3/24/05 (AL)
16902                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16903                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16904                   *vbld_inv(i-1+nres)
16905       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16906                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16907              enddo
16908       !   Obtaining the gamma derivatives from cosine derivative
16909             else
16910                do j=1,3
16911                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16912                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16913                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16914                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16915                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16916                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16917                dcosomicron(j,1,1,i)
16918                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16919                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16920                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16921                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16922                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16923       !          write(iout,*) "else",i
16924              enddo
16925             endif
16926             enddo
16927
16928 #ifdef CRYST_SC
16929       !   Derivatives of side-chain angles alpha and omega
16930 #if defined(MPI) && defined(PARINTDER)
16931             do i=ibond_start,ibond_end
16932 #else
16933             do i=2,nres-1
16934 #endif
16935               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16936                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16937                  fac6=fac5/vbld(i)
16938                  fac7=fac5*fac5
16939                  fac8=fac5/vbld(i+1)
16940                  fac9=fac5/vbld(i+nres)
16941                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16942                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16943                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16944                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16945                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16946                  sina=sqrt(1-cosa*cosa)
16947                  sino=dsin(omeg(i))
16948       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16949                  do j=1,3
16950                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16951                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16952                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16953                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16954                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16955                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16956                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16957                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16958                   vbld(i+nres))
16959                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16960                 enddo
16961       ! obtaining the derivatives of omega from sines
16962                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16963                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16964                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16965                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16966                    dsin(theta(i+1)))
16967                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16968                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16969                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16970                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16971                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16972                    coso_inv=1.0d0/dcos(omeg(i))
16973                    do j=1,3
16974                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16975                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16976                    (sino*dc_norm(j,i-1))/vbld(i)
16977                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16978                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16979                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16980                    -sino*dc_norm(j,i)/vbld(i+1)
16981                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16982                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16983                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16984                    vbld(i+nres)
16985                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16986                   enddo
16987                else
16988       !   obtaining the derivatives of omega from cosines
16989                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16990                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16991                  fac12=fac10*sina
16992                  fac13=fac12*fac12
16993                  fac14=sina*sina
16994                  do j=1,3
16995                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16996                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16997                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16998                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16999                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17000                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17001                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17002                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17003                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17004                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17005                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17006                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17007                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17008                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17009                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17010                 enddo
17011               endif
17012              else
17013                do j=1,3
17014                  do k=1,3
17015                    dalpha(k,j,i)=0.0d0
17016                    domega(k,j,i)=0.0d0
17017                  enddo
17018                enddo
17019              endif
17020              enddo
17021 #endif
17022 #if defined(MPI) && defined(PARINTDER)
17023             if (nfgtasks.gt.1) then
17024 #ifdef DEBUG
17025       !d      write (iout,*) "Gather dtheta"
17026       !d      call flush(iout)
17027             write (iout,*) "dtheta before gather"
17028             do i=1,nres
17029             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17030             enddo
17031 #endif
17032             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17033             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17034             king,FG_COMM,IERROR)
17035 #ifdef DEBUG
17036       !d      write (iout,*) "Gather dphi"
17037       !d      call flush(iout)
17038             write (iout,*) "dphi before gather"
17039             do i=1,nres
17040             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17041             enddo
17042 #endif
17043             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17044             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17045             king,FG_COMM,IERROR)
17046       !d      write (iout,*) "Gather dalpha"
17047       !d      call flush(iout)
17048 #ifdef CRYST_SC
17049             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17050             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17051             king,FG_COMM,IERROR)
17052       !d      write (iout,*) "Gather domega"
17053       !d      call flush(iout)
17054             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17055             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17056             king,FG_COMM,IERROR)
17057 #endif
17058             endif
17059 #endif
17060 #ifdef DEBUG
17061             write (iout,*) "dtheta after gather"
17062             do i=1,nres
17063             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17064             enddo
17065             write (iout,*) "dphi after gather"
17066             do i=1,nres
17067             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17068             enddo
17069             write (iout,*) "dalpha after gather"
17070             do i=1,nres
17071             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17072             enddo
17073             write (iout,*) "domega after gather"
17074             do i=1,nres
17075             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17076             enddo
17077 #endif
17078             return
17079             end subroutine intcartderiv
17080       !-----------------------------------------------------------------------------
17081             subroutine checkintcartgrad
17082       !      implicit real*8 (a-h,o-z)
17083       !      include 'DIMENSIONS'
17084 #ifdef MPI
17085             include 'mpif.h'
17086 #endif
17087       !      include 'COMMON.CHAIN'
17088       !      include 'COMMON.VAR'
17089       !      include 'COMMON.GEO'
17090       !      include 'COMMON.INTERACT'
17091       !      include 'COMMON.DERIV'
17092       !      include 'COMMON.IOUNITS'
17093       !      include 'COMMON.SETUP'
17094             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17095             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17096             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17097             real(kind=8),dimension(3) :: dc_norm_s
17098             real(kind=8) :: aincr=1.0d-5
17099             integer :: i,j
17100             real(kind=8) :: dcji
17101             do i=1,nres
17102             phi_s(i)=phi(i)
17103             theta_s(i)=theta(i)
17104             alph_s(i)=alph(i)
17105             omeg_s(i)=omeg(i)
17106             enddo
17107       ! Check theta gradient
17108             write (iout,*) &
17109              "Analytical (upper) and numerical (lower) gradient of theta"
17110             write (iout,*)
17111             do i=3,nres
17112             do j=1,3
17113               dcji=dc(j,i-2)
17114               dc(j,i-2)=dcji+aincr
17115               call chainbuild_cart
17116               call int_from_cart1(.false.)
17117           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17118           dc(j,i-2)=dcji
17119           dcji=dc(j,i-1)
17120           dc(j,i-1)=dc(j,i-1)+aincr
17121           call chainbuild_cart
17122           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17123           dc(j,i-1)=dcji
17124         enddo
17125 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17126 !el          (dtheta(j,2,i),j=1,3)
17127 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17128 !el          (dthetanum(j,2,i),j=1,3)
17129 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17130 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17131 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17132 !el        write (iout,*)
17133       enddo
17134 ! Check gamma gradient
17135       write (iout,*) &
17136        "Analytical (upper) and numerical (lower) gradient of gamma"
17137       do i=4,nres
17138         do j=1,3
17139           dcji=dc(j,i-3)
17140           dc(j,i-3)=dcji+aincr
17141           call chainbuild_cart
17142           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17143               dc(j,i-3)=dcji
17144           dcji=dc(j,i-2)
17145           dc(j,i-2)=dcji+aincr
17146           call chainbuild_cart
17147           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17148           dc(j,i-2)=dcji
17149           dcji=dc(j,i-1)
17150           dc(j,i-1)=dc(j,i-1)+aincr
17151           call chainbuild_cart
17152           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17153           dc(j,i-1)=dcji
17154         enddo
17155 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17156 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17157 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17158 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17159 !el        write (iout,'(5x,3(3f10.5,5x))') &
17160 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17161 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17162 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17163 !el        write (iout,*)
17164       enddo
17165 ! Check alpha gradient
17166       write (iout,*) &
17167        "Analytical (upper) and numerical (lower) gradient of alpha"
17168       do i=2,nres-1
17169        if(itype(i,1).ne.10) then
17170                  do j=1,3
17171                   dcji=dc(j,i-1)
17172                    dc(j,i-1)=dcji+aincr
17173               call chainbuild_cart
17174               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17175                  /aincr
17176                   dc(j,i-1)=dcji
17177               dcji=dc(j,i)
17178               dc(j,i)=dcji+aincr
17179               call chainbuild_cart
17180               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17181                  /aincr
17182               dc(j,i)=dcji
17183               dcji=dc(j,i+nres)
17184               dc(j,i+nres)=dc(j,i+nres)+aincr
17185               call chainbuild_cart
17186               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17187                  /aincr
17188              dc(j,i+nres)=dcji
17189             enddo
17190           endif
17191 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17192 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17193 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17194 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17195 !el        write (iout,'(5x,3(3f10.5,5x))') &
17196 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17197 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17198 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17199 !el        write (iout,*)
17200       enddo
17201 !     Check omega gradient
17202       write (iout,*) &
17203        "Analytical (upper) and numerical (lower) gradient of omega"
17204       do i=2,nres-1
17205        if(itype(i,1).ne.10) then
17206                  do j=1,3
17207                   dcji=dc(j,i-1)
17208                    dc(j,i-1)=dcji+aincr
17209               call chainbuild_cart
17210               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17211                  /aincr
17212                   dc(j,i-1)=dcji
17213               dcji=dc(j,i)
17214               dc(j,i)=dcji+aincr
17215               call chainbuild_cart
17216               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17217                  /aincr
17218               dc(j,i)=dcji
17219               dcji=dc(j,i+nres)
17220               dc(j,i+nres)=dc(j,i+nres)+aincr
17221               call chainbuild_cart
17222               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17223                  /aincr
17224              dc(j,i+nres)=dcji
17225             enddo
17226           endif
17227 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17228 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17229 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17230 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17231 !el        write (iout,'(5x,3(3f10.5,5x))') &
17232 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17233 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17234 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17235 !el        write (iout,*)
17236       enddo
17237       return
17238       end subroutine checkintcartgrad
17239 !-----------------------------------------------------------------------------
17240 ! q_measure.F
17241 !-----------------------------------------------------------------------------
17242       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17243 !      implicit real*8 (a-h,o-z)
17244 !      include 'DIMENSIONS'
17245 !      include 'COMMON.IOUNITS'
17246 !      include 'COMMON.CHAIN'
17247 !      include 'COMMON.INTERACT'
17248 !      include 'COMMON.VAR'
17249       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17250       integer :: kkk,nsep=3
17251       real(kind=8) :: qm      !dist,
17252       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17253       logical :: lprn=.false.
17254       logical :: flag
17255 !      real(kind=8) :: sigm,x
17256
17257 !el      sigm(x)=0.25d0*x     ! local function
17258       qqmax=1.0d10
17259       do kkk=1,nperm
17260       qq = 0.0d0
17261       nl=0
17262        if(flag) then
17263         do il=seg1+nsep,seg2
17264           do jl=seg1,il-nsep
17265             nl=nl+1
17266             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17267                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17268                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17269             dij=dist(il,jl)
17270             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17271             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17272               nl=nl+1
17273               d0ijCM=dsqrt( &
17274                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17275                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17276                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17277               dijCM=dist(il+nres,jl+nres)
17278               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17279             endif
17280             qq = qq+qqij+qqijCM
17281           enddo
17282         enddo
17283         qq = qq/nl
17284       else
17285       do il=seg1,seg2
17286         if((seg3-il).lt.3) then
17287              secseg=il+3
17288         else
17289              secseg=seg3
17290         endif
17291           do jl=secseg,seg4
17292             nl=nl+1
17293             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17294                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17295                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17296             dij=dist(il,jl)
17297             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17298             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17299               nl=nl+1
17300               d0ijCM=dsqrt( &
17301                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17302                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17303                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17304               dijCM=dist(il+nres,jl+nres)
17305               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17306             endif
17307             qq = qq+qqij+qqijCM
17308           enddo
17309         enddo
17310       qq = qq/nl
17311       endif
17312       if (qqmax.le.qq) qqmax=qq
17313       enddo
17314       qwolynes=1.0d0-qqmax
17315       return
17316       end function qwolynes
17317 !-----------------------------------------------------------------------------
17318       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17319 !      implicit real*8 (a-h,o-z)
17320 !      include 'DIMENSIONS'
17321 !      include 'COMMON.IOUNITS'
17322 !      include 'COMMON.CHAIN'
17323 !      include 'COMMON.INTERACT'
17324 !      include 'COMMON.VAR'
17325 !      include 'COMMON.MD'
17326       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17327       integer :: nsep=3, kkk
17328 !el      real(kind=8) :: dist
17329       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17330       logical :: lprn=.false.
17331       logical :: flag
17332       real(kind=8) :: sim,dd0,fac,ddqij
17333 !el      sigm(x)=0.25d0*x           ! local function
17334       do kkk=1,nperm
17335       do i=0,nres
17336         do j=1,3
17337           dqwol(j,i)=0.0d0
17338           dxqwol(j,i)=0.0d0
17339         enddo
17340       enddo
17341       nl=0
17342        if(flag) then
17343         do il=seg1+nsep,seg2
17344           do jl=seg1,il-nsep
17345             nl=nl+1
17346             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17347                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17348                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17349             dij=dist(il,jl)
17350             sim = 1.0d0/sigm(d0ij)
17351             sim = sim*sim
17352             dd0 = dij-d0ij
17353             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17354           do k=1,3
17355               ddqij = (c(k,il)-c(k,jl))*fac
17356               dqwol(k,il)=dqwol(k,il)+ddqij
17357               dqwol(k,jl)=dqwol(k,jl)-ddqij
17358             enddo
17359
17360             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17361               nl=nl+1
17362               d0ijCM=dsqrt( &
17363                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17364                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17365                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17366               dijCM=dist(il+nres,jl+nres)
17367               sim = 1.0d0/sigm(d0ijCM)
17368               sim = sim*sim
17369               dd0=dijCM-d0ijCM
17370               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17371               do k=1,3
17372                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17373                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17374                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17375               enddo
17376             endif
17377           enddo
17378         enddo
17379        else
17380         do il=seg1,seg2
17381         if((seg3-il).lt.3) then
17382              secseg=il+3
17383         else
17384              secseg=seg3
17385         endif
17386           do jl=secseg,seg4
17387             nl=nl+1
17388             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17389                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17390                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17391             dij=dist(il,jl)
17392             sim = 1.0d0/sigm(d0ij)
17393             sim = sim*sim
17394             dd0 = dij-d0ij
17395             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17396             do k=1,3
17397               ddqij = (c(k,il)-c(k,jl))*fac
17398               dqwol(k,il)=dqwol(k,il)+ddqij
17399               dqwol(k,jl)=dqwol(k,jl)-ddqij
17400             enddo
17401             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17402               nl=nl+1
17403               d0ijCM=dsqrt( &
17404                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17405                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17406                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17407               dijCM=dist(il+nres,jl+nres)
17408               sim = 1.0d0/sigm(d0ijCM)
17409               sim=sim*sim
17410               dd0 = dijCM-d0ijCM
17411               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17412               do k=1,3
17413                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17414                dxqwol(k,il)=dxqwol(k,il)+ddqij
17415                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17416               enddo
17417             endif
17418           enddo
17419         enddo
17420       endif
17421       enddo
17422        do i=0,nres
17423          do j=1,3
17424            dqwol(j,i)=dqwol(j,i)/nl
17425            dxqwol(j,i)=dxqwol(j,i)/nl
17426          enddo
17427        enddo
17428       return
17429       end subroutine qwolynes_prim
17430 !-----------------------------------------------------------------------------
17431       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17432 !      implicit real*8 (a-h,o-z)
17433 !      include 'DIMENSIONS'
17434 !      include 'COMMON.IOUNITS'
17435 !      include 'COMMON.CHAIN'
17436 !      include 'COMMON.INTERACT'
17437 !      include 'COMMON.VAR'
17438       integer :: seg1,seg2,seg3,seg4
17439       logical :: flag
17440       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17441       real(kind=8),dimension(3,0:2*nres) :: cdummy
17442       real(kind=8) :: q1,q2
17443       real(kind=8) :: delta=1.0d-10
17444       integer :: i,j
17445
17446       do i=0,nres
17447         do j=1,3
17448           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17449           cdummy(j,i)=c(j,i)
17450           c(j,i)=c(j,i)+delta
17451           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17452           qwolan(j,i)=(q2-q1)/delta
17453           c(j,i)=cdummy(j,i)
17454         enddo
17455       enddo
17456       do i=0,nres
17457         do j=1,3
17458           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17459           cdummy(j,i+nres)=c(j,i+nres)
17460           c(j,i+nres)=c(j,i+nres)+delta
17461           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17462           qwolxan(j,i)=(q2-q1)/delta
17463           c(j,i+nres)=cdummy(j,i+nres)
17464         enddo
17465       enddo
17466 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17467 !      do i=0,nct
17468 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17469 !      enddo
17470 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17471 !      do i=0,nct
17472 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17473 !      enddo
17474       return
17475       end subroutine qwol_num
17476 !-----------------------------------------------------------------------------
17477       subroutine EconstrQ
17478 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17479 !      implicit real*8 (a-h,o-z)
17480 !      include 'DIMENSIONS'
17481 !      include 'COMMON.CONTROL'
17482 !      include 'COMMON.VAR'
17483 !      include 'COMMON.MD'
17484       use MD_data
17485 !#ifndef LANG0
17486 !      include 'COMMON.LANGEVIN'
17487 !#else
17488 !      include 'COMMON.LANGEVIN.lang0'
17489 !#endif
17490 !      include 'COMMON.CHAIN'
17491 !      include 'COMMON.DERIV'
17492 !      include 'COMMON.GEO'
17493 !      include 'COMMON.LOCAL'
17494 !      include 'COMMON.INTERACT'
17495 !      include 'COMMON.IOUNITS'
17496 !      include 'COMMON.NAMES'
17497 !      include 'COMMON.TIME1'
17498       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17499       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17500                    duconst,duxconst
17501       integer :: kstart,kend,lstart,lend,idummy
17502       real(kind=8) :: delta=1.0d-7
17503       integer :: i,j,k,ii
17504       do i=0,nres
17505          do j=1,3
17506             duconst(j,i)=0.0d0
17507             dudconst(j,i)=0.0d0
17508             duxconst(j,i)=0.0d0
17509             dudxconst(j,i)=0.0d0
17510          enddo
17511       enddo
17512       Uconst=0.0d0
17513       do i=1,nfrag
17514          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17515            idummy,idummy)
17516          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17517 ! Calculating the derivatives of Constraint energy with respect to Q
17518          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17519            qinfrag(i,iset))
17520 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17521 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17522 !         hmnum=(hm2-hm1)/delta
17523 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17524 !     &   qinfrag(i,iset))
17525 !         write(iout,*) "harmonicnum frag", hmnum
17526 ! Calculating the derivatives of Q with respect to cartesian coordinates
17527          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17528           idummy,idummy)
17529 !         write(iout,*) "dqwol "
17530 !         do ii=1,nres
17531 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17532 !         enddo
17533 !         write(iout,*) "dxqwol "
17534 !         do ii=1,nres
17535 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17536 !         enddo
17537 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17538 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17539 !     &  ,idummy,idummy)
17540 !  The gradients of Uconst in Cs
17541          do ii=0,nres
17542             do j=1,3
17543                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17544                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17545             enddo
17546          enddo
17547       enddo
17548       do i=1,npair
17549          kstart=ifrag(1,ipair(1,i,iset),iset)
17550          kend=ifrag(2,ipair(1,i,iset),iset)
17551          lstart=ifrag(1,ipair(2,i,iset),iset)
17552          lend=ifrag(2,ipair(2,i,iset),iset)
17553          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17554          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17555 !  Calculating dU/dQ
17556          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17557 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17558 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17559 !         hmnum=(hm2-hm1)/delta
17560 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17561 !     &   qinpair(i,iset))
17562 !         write(iout,*) "harmonicnum pair ", hmnum
17563 ! Calculating dQ/dXi
17564          call qwolynes_prim(kstart,kend,.false.,&
17565           lstart,lend)
17566 !         write(iout,*) "dqwol "
17567 !         do ii=1,nres
17568 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17569 !         enddo
17570 !         write(iout,*) "dxqwol "
17571 !         do ii=1,nres
17572 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17573 !        enddo
17574 ! Calculating numerical gradients
17575 !        call qwol_num(kstart,kend,.false.
17576 !     &  ,lstart,lend)
17577 ! The gradients of Uconst in Cs
17578          do ii=0,nres
17579             do j=1,3
17580                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17581                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17582             enddo
17583          enddo
17584       enddo
17585 !      write(iout,*) "Uconst inside subroutine ", Uconst
17586 ! Transforming the gradients from Cs to dCs for the backbone
17587       do i=0,nres
17588          do j=i+1,nres
17589            do k=1,3
17590              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17591            enddo
17592          enddo
17593       enddo
17594 !  Transforming the gradients from Cs to dCs for the side chains
17595       do i=1,nres
17596          do j=1,3
17597            dudxconst(j,i)=duxconst(j,i)
17598          enddo
17599       enddo
17600 !      write(iout,*) "dU/ddc backbone "
17601 !       do ii=0,nres
17602 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17603 !      enddo
17604 !      write(iout,*) "dU/ddX side chain "
17605 !      do ii=1,nres
17606 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17607 !      enddo
17608 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17609 !      call dEconstrQ_num
17610       return
17611       end subroutine EconstrQ
17612 !-----------------------------------------------------------------------------
17613       subroutine dEconstrQ_num
17614 ! Calculating numerical dUconst/ddc and dUconst/ddx
17615 !      implicit real*8 (a-h,o-z)
17616 !      include 'DIMENSIONS'
17617 !      include 'COMMON.CONTROL'
17618 !      include 'COMMON.VAR'
17619 !      include 'COMMON.MD'
17620       use MD_data
17621 !#ifndef LANG0
17622 !      include 'COMMON.LANGEVIN'
17623 !#else
17624 !      include 'COMMON.LANGEVIN.lang0'
17625 !#endif
17626 !      include 'COMMON.CHAIN'
17627 !      include 'COMMON.DERIV'
17628 !      include 'COMMON.GEO'
17629 !      include 'COMMON.LOCAL'
17630 !      include 'COMMON.INTERACT'
17631 !      include 'COMMON.IOUNITS'
17632 !      include 'COMMON.NAMES'
17633 !      include 'COMMON.TIME1'
17634       real(kind=8) :: uzap1,uzap2
17635       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17636       integer :: kstart,kend,lstart,lend,idummy
17637       real(kind=8) :: delta=1.0d-7
17638 !el local variables
17639       integer :: i,ii,j
17640 !     real(kind=8) ::
17641 !     For the backbone
17642       do i=0,nres-1
17643          do j=1,3
17644             dUcartan(j,i)=0.0d0
17645             cdummy(j,i)=dc(j,i)
17646             dc(j,i)=dc(j,i)+delta
17647             call chainbuild_cart
17648           uzap2=0.0d0
17649             do ii=1,nfrag
17650              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17651                 idummy,idummy)
17652                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17653                 qinfrag(ii,iset))
17654             enddo
17655             do ii=1,npair
17656                kstart=ifrag(1,ipair(1,ii,iset),iset)
17657                kend=ifrag(2,ipair(1,ii,iset),iset)
17658                lstart=ifrag(1,ipair(2,ii,iset),iset)
17659                lend=ifrag(2,ipair(2,ii,iset),iset)
17660                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17661                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17662                  qinpair(ii,iset))
17663             enddo
17664             dc(j,i)=cdummy(j,i)
17665             call chainbuild_cart
17666             uzap1=0.0d0
17667              do ii=1,nfrag
17668              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17669                 idummy,idummy)
17670                uzap1=uzap1+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                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17680                 qinpair(ii,iset))
17681             enddo
17682             ducartan(j,i)=(uzap2-uzap1)/(delta)
17683          enddo
17684       enddo
17685 ! Calculating numerical gradients for dU/ddx
17686       do i=0,nres-1
17687          duxcartan(j,i)=0.0d0
17688          do j=1,3
17689             cdummy(j,i)=dc(j,i+nres)
17690             dc(j,i+nres)=dc(j,i+nres)+delta
17691             call chainbuild_cart
17692           uzap2=0.0d0
17693             do ii=1,nfrag
17694              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17695                 idummy,idummy)
17696                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17697                 qinfrag(ii,iset))
17698             enddo
17699             do ii=1,npair
17700                kstart=ifrag(1,ipair(1,ii,iset),iset)
17701                kend=ifrag(2,ipair(1,ii,iset),iset)
17702                lstart=ifrag(1,ipair(2,ii,iset),iset)
17703                lend=ifrag(2,ipair(2,ii,iset),iset)
17704                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17705                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17706                 qinpair(ii,iset))
17707             enddo
17708             dc(j,i+nres)=cdummy(j,i)
17709             call chainbuild_cart
17710             uzap1=0.0d0
17711              do ii=1,nfrag
17712                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17713                 ifrag(2,ii,iset),.true.,idummy,idummy)
17714                uzap1=uzap1+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                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17724                 qinpair(ii,iset))
17725             enddo
17726             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17727          enddo
17728       enddo
17729       write(iout,*) "Numerical dUconst/ddc backbone "
17730       do ii=0,nres
17731         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17732       enddo
17733 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17734 !      do ii=1,nres
17735 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17736 !      enddo
17737       return
17738       end subroutine dEconstrQ_num
17739 !-----------------------------------------------------------------------------
17740 ! ssMD.F
17741 !-----------------------------------------------------------------------------
17742       subroutine check_energies
17743
17744 !      use random, only: ran_number
17745
17746 !      implicit none
17747 !     Includes
17748 !      include 'DIMENSIONS'
17749 !      include 'COMMON.CHAIN'
17750 !      include 'COMMON.VAR'
17751 !      include 'COMMON.IOUNITS'
17752 !      include 'COMMON.SBRIDGE'
17753 !      include 'COMMON.LOCAL'
17754 !      include 'COMMON.GEO'
17755
17756 !     External functions
17757 !EL      double precision ran_number
17758 !EL      external ran_number
17759
17760 !     Local variables
17761       integer :: i,j,k,l,lmax,p,pmax
17762       real(kind=8) :: rmin,rmax
17763       real(kind=8) :: eij
17764
17765       real(kind=8) :: d
17766       real(kind=8) :: wi,rij,tj,pj
17767 !      return
17768
17769       i=5
17770       j=14
17771
17772       d=dsc(1)
17773       rmin=2.0D0
17774       rmax=12.0D0
17775
17776       lmax=10000
17777       pmax=1
17778
17779       do k=1,3
17780         c(k,i)=0.0D0
17781         c(k,j)=0.0D0
17782         c(k,nres+i)=0.0D0
17783         c(k,nres+j)=0.0D0
17784       enddo
17785
17786       do l=1,lmax
17787
17788 !t        wi=ran_number(0.0D0,pi)
17789 !        wi=ran_number(0.0D0,pi/6.0D0)
17790 !        wi=0.0D0
17791 !t        tj=ran_number(0.0D0,pi)
17792 !t        pj=ran_number(0.0D0,pi)
17793 !        pj=ran_number(0.0D0,pi/6.0D0)
17794 !        pj=0.0D0
17795
17796         do p=1,pmax
17797 !t           rij=ran_number(rmin,rmax)
17798
17799            c(1,j)=d*sin(pj)*cos(tj)
17800            c(2,j)=d*sin(pj)*sin(tj)
17801            c(3,j)=d*cos(pj)
17802
17803            c(3,nres+i)=-rij
17804
17805            c(1,i)=d*sin(wi)
17806            c(3,i)=-rij-d*cos(wi)
17807
17808            do k=1,3
17809               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17810               dc_norm(k,nres+i)=dc(k,nres+i)/d
17811               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17812               dc_norm(k,nres+j)=dc(k,nres+j)/d
17813            enddo
17814
17815            call dyn_ssbond_ene(i,j,eij)
17816         enddo
17817       enddo
17818       call exit(1)
17819       return
17820       end subroutine check_energies
17821 !-----------------------------------------------------------------------------
17822       subroutine dyn_ssbond_ene(resi,resj,eij)
17823 !      implicit none
17824 !      Includes
17825       use calc_data
17826       use comm_sschecks
17827 !      include 'DIMENSIONS'
17828 !      include 'COMMON.SBRIDGE'
17829 !      include 'COMMON.CHAIN'
17830 !      include 'COMMON.DERIV'
17831 !      include 'COMMON.LOCAL'
17832 !      include 'COMMON.INTERACT'
17833 !      include 'COMMON.VAR'
17834 !      include 'COMMON.IOUNITS'
17835 !      include 'COMMON.CALC'
17836 #ifndef CLUST
17837 #ifndef WHAM
17838        use MD_data
17839 !      include 'COMMON.MD'
17840 !      use MD, only: totT,t_bath
17841 #endif
17842 #endif
17843 !     External functions
17844 !EL      double precision h_base
17845 !EL      external h_base
17846
17847 !     Input arguments
17848       integer :: resi,resj
17849
17850 !     Output arguments
17851       real(kind=8) :: eij
17852
17853 !     Local variables
17854       logical :: havebond
17855       integer itypi,itypj
17856       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17857       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17858       real(kind=8),dimension(3) :: dcosom1,dcosom2
17859       real(kind=8) :: ed
17860       real(kind=8) :: pom1,pom2
17861       real(kind=8) :: ljA,ljB,ljXs
17862       real(kind=8),dimension(1:3) :: d_ljB
17863       real(kind=8) :: ssA,ssB,ssC,ssXs
17864       real(kind=8) :: ssxm,ljxm,ssm,ljm
17865       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17866       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17867       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17868 !-------FIRST METHOD
17869       real(kind=8) :: xm
17870       real(kind=8),dimension(1:3) :: d_xm
17871 !-------END FIRST METHOD
17872 !-------SECOND METHOD
17873 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17874 !-------END SECOND METHOD
17875
17876 !-------TESTING CODE
17877 !el      logical :: checkstop,transgrad
17878 !el      common /sschecks/ checkstop,transgrad
17879
17880       integer :: icheck,nicheck,jcheck,njcheck
17881       real(kind=8),dimension(-1:1) :: echeck
17882       real(kind=8) :: deps,ssx0,ljx0
17883 !-------END TESTING CODE
17884
17885       eij=0.0d0
17886       i=resi
17887       j=resj
17888
17889 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17890 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17891
17892       itypi=itype(i,1)
17893       dxi=dc_norm(1,nres+i)
17894       dyi=dc_norm(2,nres+i)
17895       dzi=dc_norm(3,nres+i)
17896       dsci_inv=vbld_inv(i+nres)
17897
17898       itypj=itype(j,1)
17899       xj=c(1,nres+j)-c(1,nres+i)
17900       yj=c(2,nres+j)-c(2,nres+i)
17901       zj=c(3,nres+j)-c(3,nres+i)
17902       dxj=dc_norm(1,nres+j)
17903       dyj=dc_norm(2,nres+j)
17904       dzj=dc_norm(3,nres+j)
17905       dscj_inv=vbld_inv(j+nres)
17906
17907       chi1=chi(itypi,itypj)
17908       chi2=chi(itypj,itypi)
17909       chi12=chi1*chi2
17910       chip1=chip(itypi)
17911       chip2=chip(itypj)
17912       chip12=chip1*chip2
17913       alf1=alp(itypi)
17914       alf2=alp(itypj)
17915       alf12=0.5D0*(alf1+alf2)
17916
17917       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17918       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17919 !     The following are set in sc_angular
17920 !      erij(1)=xj*rij
17921 !      erij(2)=yj*rij
17922 !      erij(3)=zj*rij
17923 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17924 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17925 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17926       call sc_angular
17927       rij=1.0D0/rij  ! Reset this so it makes sense
17928
17929       sig0ij=sigma(itypi,itypj)
17930       sig=sig0ij*dsqrt(1.0D0/sigsq)
17931
17932       ljXs=sig-sig0ij
17933       ljA=eps1*eps2rt**2*eps3rt**2
17934       ljB=ljA*bb_aq(itypi,itypj)
17935       ljA=ljA*aa_aq(itypi,itypj)
17936       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17937
17938       ssXs=d0cm
17939       deltat1=1.0d0-om1
17940       deltat2=1.0d0+om2
17941       deltat12=om2-om1+2.0d0
17942       cosphi=om12-om1*om2
17943       ssA=akcm
17944       ssB=akct*deltat12
17945       ssC=ss_depth &
17946            +akth*(deltat1*deltat1+deltat2*deltat2) &
17947            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17948       ssxm=ssXs-0.5D0*ssB/ssA
17949
17950 !-------TESTING CODE
17951 !$$$c     Some extra output
17952 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17953 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17954 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17955 !$$$      if (ssx0.gt.0.0d0) then
17956 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17957 !$$$      else
17958 !$$$        ssx0=ssxm
17959 !$$$      endif
17960 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17961 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17962 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17963 !$$$      return
17964 !-------END TESTING CODE
17965
17966 !-------TESTING CODE
17967 !     Stop and plot energy and derivative as a function of distance
17968       if (checkstop) then
17969         ssm=ssC-0.25D0*ssB*ssB/ssA
17970         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17971         if (ssm.lt.ljm .and. &
17972              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17973           nicheck=1000
17974           njcheck=1
17975           deps=0.5d-7
17976         else
17977           checkstop=.false.
17978         endif
17979       endif
17980       if (.not.checkstop) then
17981         nicheck=0
17982         njcheck=-1
17983       endif
17984
17985       do icheck=0,nicheck
17986       do jcheck=-1,njcheck
17987       if (checkstop) rij=(ssxm-1.0d0)+ &
17988              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17989 !-------END TESTING CODE
17990
17991       if (rij.gt.ljxm) then
17992         havebond=.false.
17993         ljd=rij-ljXs
17994         fac=(1.0D0/ljd)**expon
17995         e1=fac*fac*aa_aq(itypi,itypj)
17996         e2=fac*bb_aq(itypi,itypj)
17997         eij=eps1*eps2rt*eps3rt*(e1+e2)
17998         eps2der=eij*eps3rt
17999         eps3der=eij*eps2rt
18000         eij=eij*eps2rt*eps3rt
18001
18002         sigder=-sig/sigsq
18003         e1=e1*eps1*eps2rt**2*eps3rt**2
18004         ed=-expon*(e1+eij)/ljd
18005         sigder=ed*sigder
18006         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18007         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18008         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18009              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18010       else if (rij.lt.ssxm) then
18011         havebond=.true.
18012         ssd=rij-ssXs
18013         eij=ssA*ssd*ssd+ssB*ssd+ssC
18014
18015         ed=2*akcm*ssd+akct*deltat12
18016         pom1=akct*ssd
18017         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18018         eom1=-2*akth*deltat1-pom1-om2*pom2
18019         eom2= 2*akth*deltat2+pom1-om1*pom2
18020         eom12=pom2
18021       else
18022         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18023
18024         d_ssxm(1)=0.5D0*akct/ssA
18025         d_ssxm(2)=-d_ssxm(1)
18026         d_ssxm(3)=0.0D0
18027
18028         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18029         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18030         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18031         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18032
18033 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18034         xm=0.5d0*(ssxm+ljxm)
18035         do k=1,3
18036           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18037         enddo
18038         if (rij.lt.xm) then
18039           havebond=.true.
18040           ssm=ssC-0.25D0*ssB*ssB/ssA
18041           d_ssm(1)=0.5D0*akct*ssB/ssA
18042           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18043           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18044           d_ssm(3)=omega
18045           f1=(rij-xm)/(ssxm-xm)
18046           f2=(rij-ssxm)/(xm-ssxm)
18047           h1=h_base(f1,hd1)
18048           h2=h_base(f2,hd2)
18049           eij=ssm*h1+Ht*h2
18050           delta_inv=1.0d0/(xm-ssxm)
18051           deltasq_inv=delta_inv*delta_inv
18052           fac=ssm*hd1-Ht*hd2
18053           fac1=deltasq_inv*fac*(xm-rij)
18054           fac2=deltasq_inv*fac*(rij-ssxm)
18055           ed=delta_inv*(Ht*hd2-ssm*hd1)
18056           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18057           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18058           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18059         else
18060           havebond=.false.
18061           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18062           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18063           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18064           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18065                alf12/eps3rt)
18066           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18067           f1=(rij-ljxm)/(xm-ljxm)
18068           f2=(rij-xm)/(ljxm-xm)
18069           h1=h_base(f1,hd1)
18070           h2=h_base(f2,hd2)
18071           eij=Ht*h1+ljm*h2
18072           delta_inv=1.0d0/(ljxm-xm)
18073           deltasq_inv=delta_inv*delta_inv
18074           fac=Ht*hd1-ljm*hd2
18075           fac1=deltasq_inv*fac*(ljxm-rij)
18076           fac2=deltasq_inv*fac*(rij-xm)
18077           ed=delta_inv*(ljm*hd2-Ht*hd1)
18078           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18079           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18080           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18081         endif
18082 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18083
18084 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18085 !$$$        ssd=rij-ssXs
18086 !$$$        ljd=rij-ljXs
18087 !$$$        fac1=rij-ljxm
18088 !$$$        fac2=rij-ssxm
18089 !$$$
18090 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18091 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18092 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18093 !$$$
18094 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18095 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18096 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18097 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18098 !$$$        d_ssm(3)=omega
18099 !$$$
18100 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18101 !$$$        do k=1,3
18102 !$$$          d_ljm(k)=ljm*d_ljB(k)
18103 !$$$        enddo
18104 !$$$        ljm=ljm*ljB
18105 !$$$
18106 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18107 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18108 !$$$        d_ss(2)=akct*ssd
18109 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18110 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18111 !$$$        d_ss(3)=omega
18112 !$$$
18113 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18114 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18115 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18116 !$$$        do k=1,3
18117 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18118 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18119 !$$$        enddo
18120 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18121 !$$$
18122 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18123 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18124 !$$$        h1=h_base(f1,hd1)
18125 !$$$        h2=h_base(f2,hd2)
18126 !$$$        eij=ss*h1+ljf*h2
18127 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18128 !$$$        deltasq_inv=delta_inv*delta_inv
18129 !$$$        fac=ljf*hd2-ss*hd1
18130 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18131 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18132 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18133 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18134 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18135 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18136 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18137 !$$$
18138 !$$$        havebond=.false.
18139 !$$$        if (ed.gt.0.0d0) havebond=.true.
18140 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18141
18142       endif
18143
18144       if (havebond) then
18145 !#ifndef CLUST
18146 !#ifndef WHAM
18147 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18148 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18149 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18150 !        endif
18151 !#endif
18152 !#endif
18153         dyn_ssbond_ij(i,j)=eij
18154       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18155         dyn_ssbond_ij(i,j)=1.0d300
18156 !#ifndef CLUST
18157 !#ifndef WHAM
18158 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18159 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18160 !#endif
18161 !#endif
18162       endif
18163
18164 !-------TESTING CODE
18165 !el      if (checkstop) then
18166         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18167              "CHECKSTOP",rij,eij,ed
18168         echeck(jcheck)=eij
18169 !el      endif
18170       enddo
18171       if (checkstop) then
18172         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18173       endif
18174       enddo
18175       if (checkstop) then
18176         transgrad=.true.
18177         checkstop=.false.
18178       endif
18179 !-------END TESTING CODE
18180
18181       do k=1,3
18182         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18183         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18184       enddo
18185       do k=1,3
18186         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18187       enddo
18188       do k=1,3
18189         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18190              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18191              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18192         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18193              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18194              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18195       enddo
18196 !grad      do k=i,j-1
18197 !grad        do l=1,3
18198 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18199 !grad        enddo
18200 !grad      enddo
18201
18202       do l=1,3
18203         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18204         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18205       enddo
18206
18207       return
18208       end subroutine dyn_ssbond_ene
18209 !--------------------------------------------------------------------------
18210          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18211 !      implicit none
18212 !      Includes
18213       use calc_data
18214       use comm_sschecks
18215 !      include 'DIMENSIONS'
18216 !      include 'COMMON.SBRIDGE'
18217 !      include 'COMMON.CHAIN'
18218 !      include 'COMMON.DERIV'
18219 !      include 'COMMON.LOCAL'
18220 !      include 'COMMON.INTERACT'
18221 !      include 'COMMON.VAR'
18222 !      include 'COMMON.IOUNITS'
18223 !      include 'COMMON.CALC'
18224 #ifndef CLUST
18225 #ifndef WHAM
18226        use MD_data
18227 !      include 'COMMON.MD'
18228 !      use MD, only: totT,t_bath
18229 #endif
18230 #endif
18231       double precision h_base
18232       external h_base
18233
18234 !c     Input arguments
18235       integer resi,resj,resk,m,itypi,itypj,itypk
18236
18237 !c     Output arguments
18238       double precision eij,eij1,eij2,eij3
18239
18240 !c     Local variables
18241       logical havebond
18242 !c      integer itypi,itypj,k,l
18243       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18244       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18245       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18246       double precision sig0ij,ljd,sig,fac,e1,e2
18247       double precision dcosom1(3),dcosom2(3),ed
18248       double precision pom1,pom2
18249       double precision ljA,ljB,ljXs
18250       double precision d_ljB(1:3)
18251       double precision ssA,ssB,ssC,ssXs
18252       double precision ssxm,ljxm,ssm,ljm
18253       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18254       eij=0.0
18255       if (dtriss.eq.0) return
18256       i=resi
18257       j=resj
18258       k=resk
18259 !C      write(iout,*) resi,resj,resk
18260       itypi=itype(i,1)
18261       dxi=dc_norm(1,nres+i)
18262       dyi=dc_norm(2,nres+i)
18263       dzi=dc_norm(3,nres+i)
18264       dsci_inv=vbld_inv(i+nres)
18265       xi=c(1,nres+i)
18266       yi=c(2,nres+i)
18267       zi=c(3,nres+i)
18268       itypj=itype(j,1)
18269       xj=c(1,nres+j)
18270       yj=c(2,nres+j)
18271       zj=c(3,nres+j)
18272
18273       dxj=dc_norm(1,nres+j)
18274       dyj=dc_norm(2,nres+j)
18275       dzj=dc_norm(3,nres+j)
18276       dscj_inv=vbld_inv(j+nres)
18277       itypk=itype(k,1)
18278       xk=c(1,nres+k)
18279       yk=c(2,nres+k)
18280       zk=c(3,nres+k)
18281
18282       dxk=dc_norm(1,nres+k)
18283       dyk=dc_norm(2,nres+k)
18284       dzk=dc_norm(3,nres+k)
18285       dscj_inv=vbld_inv(k+nres)
18286       xij=xj-xi
18287       xik=xk-xi
18288       xjk=xk-xj
18289       yij=yj-yi
18290       yik=yk-yi
18291       yjk=yk-yj
18292       zij=zj-zi
18293       zik=zk-zi
18294       zjk=zk-zj
18295       rrij=(xij*xij+yij*yij+zij*zij)
18296       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18297       rrik=(xik*xik+yik*yik+zik*zik)
18298       rik=dsqrt(rrik)
18299       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18300       rjk=dsqrt(rrjk)
18301 !C there are three combination of distances for each trisulfide bonds
18302 !C The first case the ith atom is the center
18303 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18304 !C distance y is second distance the a,b,c,d are parameters derived for
18305 !C this problem d parameter was set as a penalty currenlty set to 1.
18306       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18307       eij1=0.0d0
18308       else
18309       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18310       endif
18311 !C second case jth atom is center
18312       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18313       eij2=0.0d0
18314       else
18315       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18316       endif
18317 !C the third case kth atom is the center
18318       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18319       eij3=0.0d0
18320       else
18321       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18322       endif
18323 !C      eij2=0.0
18324 !C      eij3=0.0
18325 !C      eij1=0.0
18326       eij=eij1+eij2+eij3
18327 !C      write(iout,*)i,j,k,eij
18328 !C The energy penalty calculated now time for the gradient part
18329 !C derivative over rij
18330       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18331       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18332             gg(1)=xij*fac/rij
18333             gg(2)=yij*fac/rij
18334             gg(3)=zij*fac/rij
18335       do m=1,3
18336         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18337         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18338       enddo
18339
18340       do l=1,3
18341         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18342         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18343       enddo
18344 !C now derivative over rik
18345       fac=-eij1**2/dtriss* &
18346       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18347       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18348             gg(1)=xik*fac/rik
18349             gg(2)=yik*fac/rik
18350             gg(3)=zik*fac/rik
18351       do m=1,3
18352         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18353         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18354       enddo
18355       do l=1,3
18356         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18357         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18358       enddo
18359 !C now derivative over rjk
18360       fac=-eij2**2/dtriss* &
18361       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18362       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18363             gg(1)=xjk*fac/rjk
18364             gg(2)=yjk*fac/rjk
18365             gg(3)=zjk*fac/rjk
18366       do m=1,3
18367         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18368         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18369       enddo
18370       do l=1,3
18371         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18372         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18373       enddo
18374       return
18375       end subroutine triple_ssbond_ene
18376
18377
18378
18379 !-----------------------------------------------------------------------------
18380       real(kind=8) function h_base(x,deriv)
18381 !     A smooth function going 0->1 in range [0,1]
18382 !     It should NOT be called outside range [0,1], it will not work there.
18383       implicit none
18384
18385 !     Input arguments
18386       real(kind=8) :: x
18387
18388 !     Output arguments
18389       real(kind=8) :: deriv
18390
18391 !     Local variables
18392       real(kind=8) :: xsq
18393
18394
18395 !     Two parabolas put together.  First derivative zero at extrema
18396 !$$$      if (x.lt.0.5D0) then
18397 !$$$        h_base=2.0D0*x*x
18398 !$$$        deriv=4.0D0*x
18399 !$$$      else
18400 !$$$        deriv=1.0D0-x
18401 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18402 !$$$        deriv=4.0D0*deriv
18403 !$$$      endif
18404
18405 !     Third degree polynomial.  First derivative zero at extrema
18406       h_base=x*x*(3.0d0-2.0d0*x)
18407       deriv=6.0d0*x*(1.0d0-x)
18408
18409 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18410 !$$$      xsq=x*x
18411 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18412 !$$$      deriv=x-1.0d0
18413 !$$$      deriv=deriv*deriv
18414 !$$$      deriv=30.0d0*xsq*deriv
18415
18416       return
18417       end function h_base
18418 !-----------------------------------------------------------------------------
18419       subroutine dyn_set_nss
18420 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18421 !      implicit none
18422       use MD_data, only: totT,t_bath
18423 !     Includes
18424 !      include 'DIMENSIONS'
18425 #ifdef MPI
18426       include "mpif.h"
18427 #endif
18428 !      include 'COMMON.SBRIDGE'
18429 !      include 'COMMON.CHAIN'
18430 !      include 'COMMON.IOUNITS'
18431 !      include 'COMMON.SETUP'
18432 !      include 'COMMON.MD'
18433 !     Local variables
18434       real(kind=8) :: emin
18435       integer :: i,j,imin,ierr
18436       integer :: diff,allnss,newnss
18437       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18438                 newihpb,newjhpb
18439       logical :: found
18440       integer,dimension(0:nfgtasks) :: i_newnss
18441       integer,dimension(0:nfgtasks) :: displ
18442       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18443       integer :: g_newnss
18444
18445       allnss=0
18446       do i=1,nres-1
18447         do j=i+1,nres
18448           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18449             allnss=allnss+1
18450             allflag(allnss)=0
18451             allihpb(allnss)=i
18452             alljhpb(allnss)=j
18453           endif
18454         enddo
18455       enddo
18456
18457 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18458
18459  1    emin=1.0d300
18460       do i=1,allnss
18461         if (allflag(i).eq.0 .and. &
18462              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18463           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18464           imin=i
18465         endif
18466       enddo
18467       if (emin.lt.1.0d300) then
18468         allflag(imin)=1
18469         do i=1,allnss
18470           if (allflag(i).eq.0 .and. &
18471                (allihpb(i).eq.allihpb(imin) .or. &
18472                alljhpb(i).eq.allihpb(imin) .or. &
18473                allihpb(i).eq.alljhpb(imin) .or. &
18474                alljhpb(i).eq.alljhpb(imin))) then
18475             allflag(i)=-1
18476           endif
18477         enddo
18478         goto 1
18479       endif
18480
18481 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18482
18483       newnss=0
18484       do i=1,allnss
18485         if (allflag(i).eq.1) then
18486           newnss=newnss+1
18487           newihpb(newnss)=allihpb(i)
18488           newjhpb(newnss)=alljhpb(i)
18489         endif
18490       enddo
18491
18492 #ifdef MPI
18493       if (nfgtasks.gt.1)then
18494
18495         call MPI_Reduce(newnss,g_newnss,1,&
18496           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18497         call MPI_Gather(newnss,1,MPI_INTEGER,&
18498                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18499         displ(0)=0
18500         do i=1,nfgtasks-1,1
18501           displ(i)=i_newnss(i-1)+displ(i-1)
18502         enddo
18503         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18504                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18505                          king,FG_COMM,IERR)
18506         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18507                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18508                          king,FG_COMM,IERR)
18509         if(fg_rank.eq.0) then
18510 !         print *,'g_newnss',g_newnss
18511 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18512 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18513          newnss=g_newnss
18514          do i=1,newnss
18515           newihpb(i)=g_newihpb(i)
18516           newjhpb(i)=g_newjhpb(i)
18517          enddo
18518         endif
18519       endif
18520 #endif
18521
18522       diff=newnss-nss
18523
18524 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18525 !       print *,newnss,nss,maxdim
18526       do i=1,nss
18527         found=.false.
18528 !        print *,newnss
18529         do j=1,newnss
18530 !!          print *,j
18531           if (idssb(i).eq.newihpb(j) .and. &
18532                jdssb(i).eq.newjhpb(j)) found=.true.
18533         enddo
18534 #ifndef CLUST
18535 #ifndef WHAM
18536 !        write(iout,*) "found",found,i,j
18537         if (.not.found.and.fg_rank.eq.0) &
18538             write(iout,'(a15,f12.2,f8.1,2i5)') &
18539              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18540 #endif
18541 #endif
18542       enddo
18543
18544       do i=1,newnss
18545         found=.false.
18546         do j=1,nss
18547 !          print *,i,j
18548           if (newihpb(i).eq.idssb(j) .and. &
18549                newjhpb(i).eq.jdssb(j)) found=.true.
18550         enddo
18551 #ifndef CLUST
18552 #ifndef WHAM
18553 !        write(iout,*) "found",found,i,j
18554         if (.not.found.and.fg_rank.eq.0) &
18555             write(iout,'(a15,f12.2,f8.1,2i5)') &
18556              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18557 #endif
18558 #endif
18559       enddo
18560
18561       nss=newnss
18562       do i=1,nss
18563         idssb(i)=newihpb(i)
18564         jdssb(i)=newjhpb(i)
18565       enddo
18566
18567       return
18568       end subroutine dyn_set_nss
18569 ! Lipid transfer energy function
18570       subroutine Eliptransfer(eliptran)
18571 !C this is done by Adasko
18572 !C      print *,"wchodze"
18573 !C structure of box:
18574 !C      water
18575 !C--bordliptop-- buffore starts
18576 !C--bufliptop--- here true lipid starts
18577 !C      lipid
18578 !C--buflipbot--- lipid ends buffore starts
18579 !C--bordlipbot--buffore ends
18580       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18581       integer :: i
18582       eliptran=0.0
18583 !      print *, "I am in eliptran"
18584       do i=ilip_start,ilip_end
18585 !C       do i=1,1
18586         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18587          cycle
18588
18589         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18590         if (positi.le.0.0) positi=positi+boxzsize
18591 !C        print *,i
18592 !C first for peptide groups
18593 !c for each residue check if it is in lipid or lipid water border area
18594        if ((positi.gt.bordlipbot)  &
18595       .and.(positi.lt.bordliptop)) then
18596 !C the energy transfer exist
18597         if (positi.lt.buflipbot) then
18598 !C what fraction I am in
18599          fracinbuf=1.0d0-      &
18600              ((positi-bordlipbot)/lipbufthick)
18601 !C lipbufthick is thickenes of lipid buffore
18602          sslip=sscalelip(fracinbuf)
18603          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18604          eliptran=eliptran+sslip*pepliptran
18605          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18606          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18607 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18608
18609 !C        print *,"doing sccale for lower part"
18610 !C         print *,i,sslip,fracinbuf,ssgradlip
18611         elseif (positi.gt.bufliptop) then
18612          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18613          sslip=sscalelip(fracinbuf)
18614          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18615          eliptran=eliptran+sslip*pepliptran
18616          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18617          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18618 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18619 !C          print *, "doing sscalefor top part"
18620 !C         print *,i,sslip,fracinbuf,ssgradlip
18621         else
18622          eliptran=eliptran+pepliptran
18623 !C         print *,"I am in true lipid"
18624         endif
18625 !C       else
18626 !C       eliptran=elpitran+0.0 ! I am in water
18627        endif
18628        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18629        enddo
18630 ! here starts the side chain transfer
18631        do i=ilip_start,ilip_end
18632         if (itype(i,1).eq.ntyp1) cycle
18633         positi=(mod(c(3,i+nres),boxzsize))
18634         if (positi.le.0) positi=positi+boxzsize
18635 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18636 !c for each residue check if it is in lipid or lipid water border area
18637 !C       respos=mod(c(3,i+nres),boxzsize)
18638 !C       print *,positi,bordlipbot,buflipbot
18639        if ((positi.gt.bordlipbot) &
18640        .and.(positi.lt.bordliptop)) then
18641 !C the energy transfer exist
18642         if (positi.lt.buflipbot) then
18643          fracinbuf=1.0d0-   &
18644            ((positi-bordlipbot)/lipbufthick)
18645 !C lipbufthick is thickenes of lipid buffore
18646          sslip=sscalelip(fracinbuf)
18647          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18648          eliptran=eliptran+sslip*liptranene(itype(i,1))
18649          gliptranx(3,i)=gliptranx(3,i) &
18650       +ssgradlip*liptranene(itype(i,1))
18651          gliptranc(3,i-1)= gliptranc(3,i-1) &
18652       +ssgradlip*liptranene(itype(i,1))
18653 !C         print *,"doing sccale for lower part"
18654         elseif (positi.gt.bufliptop) then
18655          fracinbuf=1.0d0-  &
18656       ((bordliptop-positi)/lipbufthick)
18657          sslip=sscalelip(fracinbuf)
18658          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18659          eliptran=eliptran+sslip*liptranene(itype(i,1))
18660          gliptranx(3,i)=gliptranx(3,i)  &
18661        +ssgradlip*liptranene(itype(i,1))
18662          gliptranc(3,i-1)= gliptranc(3,i-1) &
18663       +ssgradlip*liptranene(itype(i,1))
18664 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18665         else
18666          eliptran=eliptran+liptranene(itype(i,1))
18667 !C         print *,"I am in true lipid"
18668         endif
18669         endif ! if in lipid or buffor
18670 !C       else
18671 !C       eliptran=elpitran+0.0 ! I am in water
18672         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18673        enddo
18674        return
18675        end  subroutine Eliptransfer
18676 !----------------------------------NANO FUNCTIONS
18677 !C-----------------------------------------------------------------------
18678 !C-----------------------------------------------------------
18679 !C This subroutine is to mimic the histone like structure but as well can be
18680 !C utilizet to nanostructures (infinit) small modification has to be used to
18681 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18682 !C gradient has to be modified at the ends
18683 !C The energy function is Kihara potential
18684 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18685 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18686 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18687 !C simple Kihara potential
18688       subroutine calctube(Etube)
18689       real(kind=8),dimension(3) :: vectube
18690       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18691        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18692        sc_aa_tube,sc_bb_tube
18693       integer :: i,j,iti
18694       Etube=0.0d0
18695       do i=itube_start,itube_end
18696         enetube(i)=0.0d0
18697         enetube(i+nres)=0.0d0
18698       enddo
18699 !C first we calculate the distance from tube center
18700 !C for UNRES
18701        do i=itube_start,itube_end
18702 !C lets ommit dummy atoms for now
18703        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18704 !C now calculate distance from center of tube and direction vectors
18705       xmin=boxxsize
18706       ymin=boxysize
18707 ! Find minimum distance in periodic box
18708         do j=-1,1
18709          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18710          vectube(1)=vectube(1)+boxxsize*j
18711          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18712          vectube(2)=vectube(2)+boxysize*j
18713          xminact=abs(vectube(1)-tubecenter(1))
18714          yminact=abs(vectube(2)-tubecenter(2))
18715            if (xmin.gt.xminact) then
18716             xmin=xminact
18717             xtemp=vectube(1)
18718            endif
18719            if (ymin.gt.yminact) then
18720              ymin=yminact
18721              ytemp=vectube(2)
18722             endif
18723          enddo
18724       vectube(1)=xtemp
18725       vectube(2)=ytemp
18726       vectube(1)=vectube(1)-tubecenter(1)
18727       vectube(2)=vectube(2)-tubecenter(2)
18728
18729 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18730 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18731
18732 !C as the tube is infinity we do not calculate the Z-vector use of Z
18733 !C as chosen axis
18734       vectube(3)=0.0d0
18735 !C now calculte the distance
18736        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18737 !C now normalize vector
18738       vectube(1)=vectube(1)/tub_r
18739       vectube(2)=vectube(2)/tub_r
18740 !C calculte rdiffrence between r and r0
18741       rdiff=tub_r-tubeR0
18742 !C and its 6 power
18743       rdiff6=rdiff**6.0d0
18744 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18745        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18746 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18747 !C       print *,rdiff,rdiff6,pep_aa_tube
18748 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18749 !C now we calculate gradient
18750        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18751             6.0d0*pep_bb_tube)/rdiff6/rdiff
18752 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18753 !C     &rdiff,fac
18754 !C now direction of gg_tube vector
18755         do j=1,3
18756         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18757         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18758         enddo
18759         enddo
18760 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18761 !C        print *,gg_tube(1,0),"TU"
18762
18763
18764        do i=itube_start,itube_end
18765 !C Lets not jump over memory as we use many times iti
18766          iti=itype(i,1)
18767 !C lets ommit dummy atoms for now
18768          if ((iti.eq.ntyp1)  &
18769 !C in UNRES uncomment the line below as GLY has no side-chain...
18770 !C      .or.(iti.eq.10)
18771         ) cycle
18772       xmin=boxxsize
18773       ymin=boxysize
18774         do j=-1,1
18775          vectube(1)=mod((c(1,i+nres)),boxxsize)
18776          vectube(1)=vectube(1)+boxxsize*j
18777          vectube(2)=mod((c(2,i+nres)),boxysize)
18778          vectube(2)=vectube(2)+boxysize*j
18779
18780          xminact=abs(vectube(1)-tubecenter(1))
18781          yminact=abs(vectube(2)-tubecenter(2))
18782            if (xmin.gt.xminact) then
18783             xmin=xminact
18784             xtemp=vectube(1)
18785            endif
18786            if (ymin.gt.yminact) then
18787              ymin=yminact
18788              ytemp=vectube(2)
18789             endif
18790          enddo
18791       vectube(1)=xtemp
18792       vectube(2)=ytemp
18793 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18794 !C     &     tubecenter(2)
18795       vectube(1)=vectube(1)-tubecenter(1)
18796       vectube(2)=vectube(2)-tubecenter(2)
18797
18798 !C as the tube is infinity we do not calculate the Z-vector use of Z
18799 !C as chosen axis
18800       vectube(3)=0.0d0
18801 !C now calculte the distance
18802        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18803 !C now normalize vector
18804       vectube(1)=vectube(1)/tub_r
18805       vectube(2)=vectube(2)/tub_r
18806
18807 !C calculte rdiffrence between r and r0
18808       rdiff=tub_r-tubeR0
18809 !C and its 6 power
18810       rdiff6=rdiff**6.0d0
18811 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18812        sc_aa_tube=sc_aa_tube_par(iti)
18813        sc_bb_tube=sc_bb_tube_par(iti)
18814        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18815        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18816              6.0d0*sc_bb_tube/rdiff6/rdiff
18817 !C now direction of gg_tube vector
18818          do j=1,3
18819           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18820           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18821          enddo
18822         enddo
18823         do i=itube_start,itube_end
18824           Etube=Etube+enetube(i)+enetube(i+nres)
18825         enddo
18826 !C        print *,"ETUBE", etube
18827         return
18828         end subroutine calctube
18829 !C TO DO 1) add to total energy
18830 !C       2) add to gradient summation
18831 !C       3) add reading parameters (AND of course oppening of PARAM file)
18832 !C       4) add reading the center of tube
18833 !C       5) add COMMONs
18834 !C       6) add to zerograd
18835 !C       7) allocate matrices
18836
18837
18838 !C-----------------------------------------------------------------------
18839 !C-----------------------------------------------------------
18840 !C This subroutine is to mimic the histone like structure but as well can be
18841 !C utilizet to nanostructures (infinit) small modification has to be used to
18842 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18843 !C gradient has to be modified at the ends
18844 !C The energy function is Kihara potential
18845 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18846 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18847 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18848 !C simple Kihara potential
18849       subroutine calctube2(Etube)
18850             real(kind=8),dimension(3) :: vectube
18851       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18852        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18853        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18854       integer:: i,j,iti
18855       Etube=0.0d0
18856       do i=itube_start,itube_end
18857         enetube(i)=0.0d0
18858         enetube(i+nres)=0.0d0
18859       enddo
18860 !C first we calculate the distance from tube center
18861 !C first sugare-phosphate group for NARES this would be peptide group
18862 !C for UNRES
18863        do i=itube_start,itube_end
18864 !C lets ommit dummy atoms for now
18865
18866        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18867 !C now calculate distance from center of tube and direction vectors
18868 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18869 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18870 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18871 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18872       xmin=boxxsize
18873       ymin=boxysize
18874         do j=-1,1
18875          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18876          vectube(1)=vectube(1)+boxxsize*j
18877          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18878          vectube(2)=vectube(2)+boxysize*j
18879
18880          xminact=abs(vectube(1)-tubecenter(1))
18881          yminact=abs(vectube(2)-tubecenter(2))
18882            if (xmin.gt.xminact) then
18883             xmin=xminact
18884             xtemp=vectube(1)
18885            endif
18886            if (ymin.gt.yminact) then
18887              ymin=yminact
18888              ytemp=vectube(2)
18889             endif
18890          enddo
18891       vectube(1)=xtemp
18892       vectube(2)=ytemp
18893       vectube(1)=vectube(1)-tubecenter(1)
18894       vectube(2)=vectube(2)-tubecenter(2)
18895
18896 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18897 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18898
18899 !C as the tube is infinity we do not calculate the Z-vector use of Z
18900 !C as chosen axis
18901       vectube(3)=0.0d0
18902 !C now calculte the distance
18903        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18904 !C now normalize vector
18905       vectube(1)=vectube(1)/tub_r
18906       vectube(2)=vectube(2)/tub_r
18907 !C calculte rdiffrence between r and r0
18908       rdiff=tub_r-tubeR0
18909 !C and its 6 power
18910       rdiff6=rdiff**6.0d0
18911 !C THIS FRAGMENT MAKES TUBE FINITE
18912         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18913         if (positi.le.0) positi=positi+boxzsize
18914 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18915 !c for each residue check if it is in lipid or lipid water border area
18916 !C       respos=mod(c(3,i+nres),boxzsize)
18917 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18918        if ((positi.gt.bordtubebot)  &
18919         .and.(positi.lt.bordtubetop)) then
18920 !C the energy transfer exist
18921         if (positi.lt.buftubebot) then
18922          fracinbuf=1.0d0-  &
18923            ((positi-bordtubebot)/tubebufthick)
18924 !C lipbufthick is thickenes of lipid buffore
18925          sstube=sscalelip(fracinbuf)
18926          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18927 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18928          enetube(i)=enetube(i)+sstube*tubetranenepep
18929 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18930 !C     &+ssgradtube*tubetranene(itype(i,1))
18931 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18932 !C     &+ssgradtube*tubetranene(itype(i,1))
18933 !C         print *,"doing sccale for lower part"
18934         elseif (positi.gt.buftubetop) then
18935          fracinbuf=1.0d0-  &
18936         ((bordtubetop-positi)/tubebufthick)
18937          sstube=sscalelip(fracinbuf)
18938          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18939          enetube(i)=enetube(i)+sstube*tubetranenepep
18940 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18941 !C     &+ssgradtube*tubetranene(itype(i,1))
18942 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18943 !C     &+ssgradtube*tubetranene(itype(i,1))
18944 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18945         else
18946          sstube=1.0d0
18947          ssgradtube=0.0d0
18948          enetube(i)=enetube(i)+sstube*tubetranenepep
18949 !C         print *,"I am in true lipid"
18950         endif
18951         else
18952 !C          sstube=0.0d0
18953 !C          ssgradtube=0.0d0
18954         cycle
18955         endif ! if in lipid or buffor
18956
18957 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18958        enetube(i)=enetube(i)+sstube* &
18959         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18960 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18961 !C       print *,rdiff,rdiff6,pep_aa_tube
18962 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18963 !C now we calculate gradient
18964        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18965              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18966 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18967 !C     &rdiff,fac
18968
18969 !C now direction of gg_tube vector
18970        do j=1,3
18971         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18972         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18973         enddo
18974          gg_tube(3,i)=gg_tube(3,i)  &
18975        +ssgradtube*enetube(i)/sstube/2.0d0
18976          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18977        +ssgradtube*enetube(i)/sstube/2.0d0
18978
18979         enddo
18980 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18981 !C        print *,gg_tube(1,0),"TU"
18982         do i=itube_start,itube_end
18983 !C Lets not jump over memory as we use many times iti
18984          iti=itype(i,1)
18985 !C lets ommit dummy atoms for now
18986          if ((iti.eq.ntyp1) &
18987 !!C in UNRES uncomment the line below as GLY has no side-chain...
18988            .or.(iti.eq.10) &
18989           ) cycle
18990           vectube(1)=c(1,i+nres)
18991           vectube(1)=mod(vectube(1),boxxsize)
18992           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18993           vectube(2)=c(2,i+nres)
18994           vectube(2)=mod(vectube(2),boxysize)
18995           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18996
18997       vectube(1)=vectube(1)-tubecenter(1)
18998       vectube(2)=vectube(2)-tubecenter(2)
18999 !C THIS FRAGMENT MAKES TUBE FINITE
19000         positi=(mod(c(3,i+nres),boxzsize))
19001         if (positi.le.0) positi=positi+boxzsize
19002 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19003 !c for each residue check if it is in lipid or lipid water border area
19004 !C       respos=mod(c(3,i+nres),boxzsize)
19005 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19006
19007        if ((positi.gt.bordtubebot)  &
19008         .and.(positi.lt.bordtubetop)) then
19009 !C the energy transfer exist
19010         if (positi.lt.buftubebot) then
19011          fracinbuf=1.0d0- &
19012             ((positi-bordtubebot)/tubebufthick)
19013 !C lipbufthick is thickenes of lipid buffore
19014          sstube=sscalelip(fracinbuf)
19015          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19016 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19017          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19018 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19019 !C     &+ssgradtube*tubetranene(itype(i,1))
19020 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19021 !C     &+ssgradtube*tubetranene(itype(i,1))
19022 !C         print *,"doing sccale for lower part"
19023         elseif (positi.gt.buftubetop) then
19024          fracinbuf=1.0d0- &
19025         ((bordtubetop-positi)/tubebufthick)
19026
19027          sstube=sscalelip(fracinbuf)
19028          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19029          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19030 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19031 !C     &+ssgradtube*tubetranene(itype(i,1))
19032 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19033 !C     &+ssgradtube*tubetranene(itype(i,1))
19034 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19035         else
19036          sstube=1.0d0
19037          ssgradtube=0.0d0
19038          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19039 !C         print *,"I am in true lipid"
19040         endif
19041         else
19042 !C          sstube=0.0d0
19043 !C          ssgradtube=0.0d0
19044         cycle
19045         endif ! if in lipid or buffor
19046 !CEND OF FINITE FRAGMENT
19047 !C as the tube is infinity we do not calculate the Z-vector use of Z
19048 !C as chosen axis
19049       vectube(3)=0.0d0
19050 !C now calculte the distance
19051        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19052 !C now normalize vector
19053       vectube(1)=vectube(1)/tub_r
19054       vectube(2)=vectube(2)/tub_r
19055 !C calculte rdiffrence between r and r0
19056       rdiff=tub_r-tubeR0
19057 !C and its 6 power
19058       rdiff6=rdiff**6.0d0
19059 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19060        sc_aa_tube=sc_aa_tube_par(iti)
19061        sc_bb_tube=sc_bb_tube_par(iti)
19062        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19063                        *sstube+enetube(i+nres)
19064 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19065 !C now we calculate gradient
19066        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19067             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19068 !C now direction of gg_tube vector
19069          do j=1,3
19070           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19071           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19072          enddo
19073          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19074        +ssgradtube*enetube(i+nres)/sstube
19075          gg_tube(3,i-1)= gg_tube(3,i-1) &
19076        +ssgradtube*enetube(i+nres)/sstube
19077
19078         enddo
19079         do i=itube_start,itube_end
19080           Etube=Etube+enetube(i)+enetube(i+nres)
19081         enddo
19082 !C        print *,"ETUBE", etube
19083         return
19084         end subroutine calctube2
19085 !=====================================================================================================================================
19086       subroutine calcnano(Etube)
19087       real(kind=8),dimension(3) :: vectube
19088
19089       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19090        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19091        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19092        integer:: i,j,iti,r
19093
19094       Etube=0.0d0
19095 !      print *,itube_start,itube_end,"poczatek"
19096       do i=itube_start,itube_end
19097         enetube(i)=0.0d0
19098         enetube(i+nres)=0.0d0
19099       enddo
19100 !C first we calculate the distance from tube center
19101 !C first sugare-phosphate group for NARES this would be peptide group
19102 !C for UNRES
19103        do i=itube_start,itube_end
19104 !C lets ommit dummy atoms for now
19105        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19106 !C now calculate distance from center of tube and direction vectors
19107       xmin=boxxsize
19108       ymin=boxysize
19109       zmin=boxzsize
19110
19111         do j=-1,1
19112          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19113          vectube(1)=vectube(1)+boxxsize*j
19114          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19115          vectube(2)=vectube(2)+boxysize*j
19116          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19117          vectube(3)=vectube(3)+boxzsize*j
19118
19119
19120          xminact=dabs(vectube(1)-tubecenter(1))
19121          yminact=dabs(vectube(2)-tubecenter(2))
19122          zminact=dabs(vectube(3)-tubecenter(3))
19123
19124            if (xmin.gt.xminact) then
19125             xmin=xminact
19126             xtemp=vectube(1)
19127            endif
19128            if (ymin.gt.yminact) then
19129              ymin=yminact
19130              ytemp=vectube(2)
19131             endif
19132            if (zmin.gt.zminact) then
19133              zmin=zminact
19134              ztemp=vectube(3)
19135             endif
19136          enddo
19137       vectube(1)=xtemp
19138       vectube(2)=ytemp
19139       vectube(3)=ztemp
19140
19141       vectube(1)=vectube(1)-tubecenter(1)
19142       vectube(2)=vectube(2)-tubecenter(2)
19143       vectube(3)=vectube(3)-tubecenter(3)
19144
19145 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19146 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19147 !C as the tube is infinity we do not calculate the Z-vector use of Z
19148 !C as chosen axis
19149 !C      vectube(3)=0.0d0
19150 !C now calculte the distance
19151        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19152 !C now normalize vector
19153       vectube(1)=vectube(1)/tub_r
19154       vectube(2)=vectube(2)/tub_r
19155       vectube(3)=vectube(3)/tub_r
19156 !C calculte rdiffrence between r and r0
19157       rdiff=tub_r-tubeR0
19158 !C and its 6 power
19159       rdiff6=rdiff**6.0d0
19160 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19161        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19162 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19163 !C       print *,rdiff,rdiff6,pep_aa_tube
19164 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19165 !C now we calculate gradient
19166        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19167             6.0d0*pep_bb_tube)/rdiff6/rdiff
19168 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19169 !C     &rdiff,fac
19170          if (acavtubpep.eq.0.0d0) then
19171 !C go to 667
19172          enecavtube(i)=0.0
19173          faccav=0.0
19174          else
19175          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19176          enecavtube(i)=  &
19177         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19178         /denominator
19179          enecavtube(i)=0.0
19180          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19181         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19182         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19183         /denominator**2.0d0
19184 !C         faccav=0.0
19185 !C         fac=fac+faccav
19186 !C 667     continue
19187          endif
19188           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19189         do j=1,3
19190         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19191         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19192         enddo
19193         enddo
19194
19195        do i=itube_start,itube_end
19196         enecavtube(i)=0.0d0
19197 !C Lets not jump over memory as we use many times iti
19198          iti=itype(i,1)
19199 !C lets ommit dummy atoms for now
19200          if ((iti.eq.ntyp1) &
19201 !C in UNRES uncomment the line below as GLY has no side-chain...
19202 !C      .or.(iti.eq.10)
19203          ) cycle
19204       xmin=boxxsize
19205       ymin=boxysize
19206       zmin=boxzsize
19207         do j=-1,1
19208          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19209          vectube(1)=vectube(1)+boxxsize*j
19210          vectube(2)=dmod((c(2,i+nres)),boxysize)
19211          vectube(2)=vectube(2)+boxysize*j
19212          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19213          vectube(3)=vectube(3)+boxzsize*j
19214
19215
19216          xminact=dabs(vectube(1)-tubecenter(1))
19217          yminact=dabs(vectube(2)-tubecenter(2))
19218          zminact=dabs(vectube(3)-tubecenter(3))
19219
19220            if (xmin.gt.xminact) then
19221             xmin=xminact
19222             xtemp=vectube(1)
19223            endif
19224            if (ymin.gt.yminact) then
19225              ymin=yminact
19226              ytemp=vectube(2)
19227             endif
19228            if (zmin.gt.zminact) then
19229              zmin=zminact
19230              ztemp=vectube(3)
19231             endif
19232          enddo
19233       vectube(1)=xtemp
19234       vectube(2)=ytemp
19235       vectube(3)=ztemp
19236
19237 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19238 !C     &     tubecenter(2)
19239       vectube(1)=vectube(1)-tubecenter(1)
19240       vectube(2)=vectube(2)-tubecenter(2)
19241       vectube(3)=vectube(3)-tubecenter(3)
19242 !C now calculte the distance
19243        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19244 !C now normalize vector
19245       vectube(1)=vectube(1)/tub_r
19246       vectube(2)=vectube(2)/tub_r
19247       vectube(3)=vectube(3)/tub_r
19248
19249 !C calculte rdiffrence between r and r0
19250       rdiff=tub_r-tubeR0
19251 !C and its 6 power
19252       rdiff6=rdiff**6.0d0
19253        sc_aa_tube=sc_aa_tube_par(iti)
19254        sc_bb_tube=sc_bb_tube_par(iti)
19255        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19256 !C       enetube(i+nres)=0.0d0
19257 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19258 !C now we calculate gradient
19259        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19260             6.0d0*sc_bb_tube/rdiff6/rdiff
19261 !C       fac=0.0
19262 !C now direction of gg_tube vector
19263 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19264          if (acavtub(iti).eq.0.0d0) then
19265 !C go to 667
19266          enecavtube(i+nres)=0.0d0
19267          faccav=0.0d0
19268          else
19269          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19270          enecavtube(i+nres)=   &
19271         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19272         /denominator
19273 !C         enecavtube(i)=0.0
19274          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19275         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19276         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19277         /denominator**2.0d0
19278 !C         faccav=0.0
19279          fac=fac+faccav
19280 !C 667     continue
19281          endif
19282 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19283 !C     &   enecavtube(i),faccav
19284 !C         print *,"licz=",
19285 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19286 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19287          do j=1,3
19288           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19289           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19290          enddo
19291           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19292         enddo
19293
19294
19295
19296         do i=itube_start,itube_end
19297           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19298          +enecavtube(i+nres)
19299         enddo
19300 !        do i=1,20
19301 !         print *,"begin", i,"a"
19302 !         do r=1,10000
19303 !          rdiff=r/100.0d0
19304 !          rdiff6=rdiff**6.0d0
19305 !          sc_aa_tube=sc_aa_tube_par(i)
19306 !          sc_bb_tube=sc_bb_tube_par(i)
19307 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19308 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19309 !          enecavtube(i)=   &
19310 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19311 !         /denominator
19312
19313 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19314 !         enddo
19315 !         print *,"end",i,"a"
19316 !        enddo
19317 !C        print *,"ETUBE", etube
19318         return
19319         end subroutine calcnano
19320
19321 !===============================================
19322 !--------------------------------------------------------------------------------
19323 !C first for shielding is setting of function of side-chains
19324
19325        subroutine set_shield_fac2
19326        real(kind=8) :: div77_81=0.974996043d0, &
19327         div4_81=0.2222222222d0
19328        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19329          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19330          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19331          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19332 !C the vector between center of side_chain and peptide group
19333        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19334          pept_group,costhet_grad,cosphi_grad_long, &
19335          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19336          sh_frac_dist_grad,pep_side
19337         integer i,j,k
19338 !C      write(2,*) "ivec",ivec_start,ivec_end
19339       do i=1,nres
19340         fac_shield(i)=0.0d0
19341         do j=1,3
19342         grad_shield(j,i)=0.0d0
19343         enddo
19344       enddo
19345       do i=ivec_start,ivec_end
19346 !C      do i=1,nres-1
19347 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19348       ishield_list(i)=0
19349       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19350 !Cif there two consequtive dummy atoms there is no peptide group between them
19351 !C the line below has to be changed for FGPROC>1
19352       VolumeTotal=0.0
19353       do k=1,nres
19354        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19355        dist_pep_side=0.0
19356        dist_side_calf=0.0
19357        do j=1,3
19358 !C first lets set vector conecting the ithe side-chain with kth side-chain
19359       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19360 !C      pep_side(j)=2.0d0
19361 !C and vector conecting the side-chain with its proper calfa
19362       side_calf(j)=c(j,k+nres)-c(j,k)
19363 !C      side_calf(j)=2.0d0
19364       pept_group(j)=c(j,i)-c(j,i+1)
19365 !C lets have their lenght
19366       dist_pep_side=pep_side(j)**2+dist_pep_side
19367       dist_side_calf=dist_side_calf+side_calf(j)**2
19368       dist_pept_group=dist_pept_group+pept_group(j)**2
19369       enddo
19370        dist_pep_side=sqrt(dist_pep_side)
19371        dist_pept_group=sqrt(dist_pept_group)
19372        dist_side_calf=sqrt(dist_side_calf)
19373       do j=1,3
19374         pep_side_norm(j)=pep_side(j)/dist_pep_side
19375         side_calf_norm(j)=dist_side_calf
19376       enddo
19377 !C now sscale fraction
19378        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19379 !C       print *,buff_shield,"buff"
19380 !C now sscale
19381         if (sh_frac_dist.le.0.0) cycle
19382 !C        print *,ishield_list(i),i
19383 !C If we reach here it means that this side chain reaches the shielding sphere
19384 !C Lets add him to the list for gradient
19385         ishield_list(i)=ishield_list(i)+1
19386 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19387 !C this list is essential otherwise problem would be O3
19388         shield_list(ishield_list(i),i)=k
19389 !C Lets have the sscale value
19390         if (sh_frac_dist.gt.1.0) then
19391          scale_fac_dist=1.0d0
19392          do j=1,3
19393          sh_frac_dist_grad(j)=0.0d0
19394          enddo
19395         else
19396          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19397                         *(2.0d0*sh_frac_dist-3.0d0)
19398          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19399                        /dist_pep_side/buff_shield*0.5d0
19400          do j=1,3
19401          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19402 !C         sh_frac_dist_grad(j)=0.0d0
19403 !C         scale_fac_dist=1.0d0
19404 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19405 !C     &                    sh_frac_dist_grad(j)
19406          enddo
19407         endif
19408 !C this is what is now we have the distance scaling now volume...
19409       short=short_r_sidechain(itype(k,1))
19410       long=long_r_sidechain(itype(k,1))
19411       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19412       sinthet=short/dist_pep_side*costhet
19413 !C now costhet_grad
19414 !C       costhet=0.6d0
19415 !C       sinthet=0.8
19416        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19417 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19418 !C     &             -short/dist_pep_side**2/costhet)
19419 !C       costhet_fac=0.0d0
19420        do j=1,3
19421          costhet_grad(j)=costhet_fac*pep_side(j)
19422        enddo
19423 !C remember for the final gradient multiply costhet_grad(j)
19424 !C for side_chain by factor -2 !
19425 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19426 !C pep_side0pept_group is vector multiplication
19427       pep_side0pept_group=0.0d0
19428       do j=1,3
19429       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19430       enddo
19431       cosalfa=(pep_side0pept_group/ &
19432       (dist_pep_side*dist_side_calf))
19433       fac_alfa_sin=1.0d0-cosalfa**2
19434       fac_alfa_sin=dsqrt(fac_alfa_sin)
19435       rkprim=fac_alfa_sin*(long-short)+short
19436 !C      rkprim=short
19437
19438 !C now costhet_grad
19439        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19440 !C       cosphi=0.6
19441        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19442        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19443            dist_pep_side**2)
19444 !C       sinphi=0.8
19445        do j=1,3
19446          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19447       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19448       *(long-short)/fac_alfa_sin*cosalfa/ &
19449       ((dist_pep_side*dist_side_calf))* &
19450       ((side_calf(j))-cosalfa* &
19451       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19452 !C       cosphi_grad_long(j)=0.0d0
19453         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19454       *(long-short)/fac_alfa_sin*cosalfa &
19455       /((dist_pep_side*dist_side_calf))* &
19456       (pep_side(j)- &
19457       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19458 !C       cosphi_grad_loc(j)=0.0d0
19459        enddo
19460 !C      print *,sinphi,sinthet
19461       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19462      &                    /VSolvSphere_div
19463 !C     &                    *wshield
19464 !C now the gradient...
19465       do j=1,3
19466       grad_shield(j,i)=grad_shield(j,i) &
19467 !C gradient po skalowaniu
19468                      +(sh_frac_dist_grad(j)*VofOverlap &
19469 !C  gradient po costhet
19470             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19471         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19472             sinphi/sinthet*costhet*costhet_grad(j) &
19473            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19474         )*wshield
19475 !C grad_shield_side is Cbeta sidechain gradient
19476       grad_shield_side(j,ishield_list(i),i)=&
19477              (sh_frac_dist_grad(j)*-2.0d0&
19478              *VofOverlap&
19479             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19480        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19481             sinphi/sinthet*costhet*costhet_grad(j)&
19482            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19483             )*wshield
19484
19485        grad_shield_loc(j,ishield_list(i),i)=   &
19486             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19487       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19488             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19489              ))&
19490              *wshield
19491       enddo
19492       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19493       enddo
19494       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19495
19496 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19497       enddo
19498       return
19499       end subroutine set_shield_fac2
19500 !----------------------------------------------------------------------------
19501 ! SOUBROUTINE FOR AFM
19502        subroutine AFMvel(Eafmforce)
19503        use MD_data, only:totTafm
19504       real(kind=8),dimension(3) :: diffafm
19505       real(kind=8) :: afmdist,Eafmforce
19506        integer :: i
19507 !C Only for check grad COMMENT if not used for checkgrad
19508 !C      totT=3.0d0
19509 !C--------------------------------------------------------
19510 !C      print *,"wchodze"
19511       afmdist=0.0d0
19512       Eafmforce=0.0d0
19513       do i=1,3
19514       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19515       afmdist=afmdist+diffafm(i)**2
19516       enddo
19517       afmdist=dsqrt(afmdist)
19518 !      totTafm=3.0
19519       Eafmforce=0.5d0*forceAFMconst &
19520       *(distafminit+totTafm*velAFMconst-afmdist)**2
19521 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19522       do i=1,3
19523       gradafm(i,afmend-1)=-forceAFMconst* &
19524        (distafminit+totTafm*velAFMconst-afmdist) &
19525        *diffafm(i)/afmdist
19526       gradafm(i,afmbeg-1)=forceAFMconst* &
19527       (distafminit+totTafm*velAFMconst-afmdist) &
19528       *diffafm(i)/afmdist
19529       enddo
19530 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19531       return
19532       end subroutine AFMvel
19533 !---------------------------------------------------------
19534        subroutine AFMforce(Eafmforce)
19535
19536       real(kind=8),dimension(3) :: diffafm
19537 !      real(kind=8) ::afmdist
19538       real(kind=8) :: afmdist,Eafmforce
19539       integer :: i
19540       afmdist=0.0d0
19541       Eafmforce=0.0d0
19542       do i=1,3
19543       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19544       afmdist=afmdist+diffafm(i)**2
19545       enddo
19546       afmdist=dsqrt(afmdist)
19547 !      print *,afmdist,distafminit
19548       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19549       do i=1,3
19550       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19551       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19552       enddo
19553 !C      print *,'AFM',Eafmforce
19554       return
19555       end subroutine AFMforce
19556
19557 !-----------------------------------------------------------------------------
19558 #ifdef WHAM
19559       subroutine read_ssHist
19560 !      implicit none
19561 !      Includes
19562 !      include 'DIMENSIONS'
19563 !      include "DIMENSIONS.FREE"
19564 !      include 'COMMON.FREE'
19565 !     Local variables
19566       integer :: i,j
19567       character(len=80) :: controlcard
19568
19569       do i=1,dyn_nssHist
19570         call card_concat(controlcard,.true.)
19571         read(controlcard,*) &
19572              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19573       enddo
19574
19575       return
19576       end subroutine read_ssHist
19577 #endif
19578 !-----------------------------------------------------------------------------
19579       integer function indmat(i,j)
19580 !el
19581 ! get the position of the jth ijth fragment of the chain coordinate system
19582 ! in the fromto array.
19583         integer :: i,j
19584
19585         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19586       return
19587       end function indmat
19588 !-----------------------------------------------------------------------------
19589       real(kind=8) function sigm(x)
19590 !el
19591        real(kind=8) :: x
19592         sigm=0.25d0*x
19593       return
19594       end function sigm
19595 !-----------------------------------------------------------------------------
19596 !-----------------------------------------------------------------------------
19597       subroutine alloc_ener_arrays
19598 !EL Allocation of arrays used by module energy
19599       use MD_data, only: mset
19600 !el local variables
19601       integer :: i,j
19602
19603       if(nres.lt.100) then
19604         maxconts=nres
19605       elseif(nres.lt.200) then
19606         maxconts=0.8*nres      ! Max. number of contacts per residue
19607       else
19608         maxconts=0.6*nres ! (maxconts=maxres/4)
19609       endif
19610       maxcont=12*nres      ! Max. number of SC contacts
19611       maxvar=6*nres      ! Max. number of variables
19612 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19613       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19614 !----------------------
19615 ! arrays in subroutine init_int_table
19616 !el#ifdef MPI
19617 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19618 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19619 !el#endif
19620       allocate(nint_gr(nres))
19621       allocate(nscp_gr(nres))
19622       allocate(ielstart(nres))
19623       allocate(ielend(nres))
19624 !(maxres)
19625       allocate(istart(nres,maxint_gr))
19626       allocate(iend(nres,maxint_gr))
19627 !(maxres,maxint_gr)
19628       allocate(iscpstart(nres,maxint_gr))
19629       allocate(iscpend(nres,maxint_gr))
19630 !(maxres,maxint_gr)
19631       allocate(ielstart_vdw(nres))
19632       allocate(ielend_vdw(nres))
19633 !(maxres)
19634       allocate(nint_gr_nucl(nres))
19635       allocate(nscp_gr_nucl(nres))
19636       allocate(ielstart_nucl(nres))
19637       allocate(ielend_nucl(nres))
19638 !(maxres)
19639       allocate(istart_nucl(nres,maxint_gr))
19640       allocate(iend_nucl(nres,maxint_gr))
19641 !(maxres,maxint_gr)
19642       allocate(iscpstart_nucl(nres,maxint_gr))
19643       allocate(iscpend_nucl(nres,maxint_gr))
19644 !(maxres,maxint_gr)
19645       allocate(ielstart_vdw_nucl(nres))
19646       allocate(ielend_vdw_nucl(nres))
19647
19648       allocate(lentyp(0:nfgtasks-1))
19649 !(0:maxprocs-1)
19650 !----------------------
19651 ! commom.contacts
19652 !      common /contacts/
19653       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19654       allocate(icont(2,maxcont))
19655 !(2,maxcont)
19656 !      common /contacts1/
19657       allocate(num_cont(0:nres+4))
19658 !(maxres)
19659       allocate(jcont(maxconts,nres))
19660 !(maxconts,maxres)
19661       allocate(facont(maxconts,nres))
19662 !(maxconts,maxres)
19663       allocate(gacont(3,maxconts,nres))
19664 !(3,maxconts,maxres)
19665 !      common /contacts_hb/
19666       allocate(gacontp_hb1(3,maxconts,nres))
19667       allocate(gacontp_hb2(3,maxconts,nres))
19668       allocate(gacontp_hb3(3,maxconts,nres))
19669       allocate(gacontm_hb1(3,maxconts,nres))
19670       allocate(gacontm_hb2(3,maxconts,nres))
19671       allocate(gacontm_hb3(3,maxconts,nres))
19672       allocate(gacont_hbr(3,maxconts,nres))
19673       allocate(grij_hb_cont(3,maxconts,nres))
19674 !(3,maxconts,maxres)
19675       allocate(facont_hb(maxconts,nres))
19676
19677       allocate(ees0p(maxconts,nres))
19678       allocate(ees0m(maxconts,nres))
19679       allocate(d_cont(maxconts,nres))
19680       allocate(ees0plist(maxconts,nres))
19681
19682 !(maxconts,maxres)
19683       allocate(num_cont_hb(nres))
19684 !(maxres)
19685       allocate(jcont_hb(maxconts,nres))
19686 !(maxconts,maxres)
19687 !      common /rotat/
19688       allocate(Ug(2,2,nres))
19689       allocate(Ugder(2,2,nres))
19690       allocate(Ug2(2,2,nres))
19691       allocate(Ug2der(2,2,nres))
19692 !(2,2,maxres)
19693       allocate(obrot(2,nres))
19694       allocate(obrot2(2,nres))
19695       allocate(obrot_der(2,nres))
19696       allocate(obrot2_der(2,nres))
19697 !(2,maxres)
19698 !      common /precomp1/
19699       allocate(mu(2,nres))
19700       allocate(muder(2,nres))
19701       allocate(Ub2(2,nres))
19702       Ub2(1,:)=0.0d0
19703       Ub2(2,:)=0.0d0
19704       allocate(Ub2der(2,nres))
19705       allocate(Ctobr(2,nres))
19706       allocate(Ctobrder(2,nres))
19707       allocate(Dtobr2(2,nres))
19708       allocate(Dtobr2der(2,nres))
19709 !(2,maxres)
19710       allocate(EUg(2,2,nres))
19711       allocate(EUgder(2,2,nres))
19712       allocate(CUg(2,2,nres))
19713       allocate(CUgder(2,2,nres))
19714       allocate(DUg(2,2,nres))
19715       allocate(Dugder(2,2,nres))
19716       allocate(DtUg2(2,2,nres))
19717       allocate(DtUg2der(2,2,nres))
19718 !(2,2,maxres)
19719 !      common /precomp2/
19720       allocate(Ug2Db1t(2,nres))
19721       allocate(Ug2Db1tder(2,nres))
19722       allocate(CUgb2(2,nres))
19723       allocate(CUgb2der(2,nres))
19724 !(2,maxres)
19725       allocate(EUgC(2,2,nres))
19726       allocate(EUgCder(2,2,nres))
19727       allocate(EUgD(2,2,nres))
19728       allocate(EUgDder(2,2,nres))
19729       allocate(DtUg2EUg(2,2,nres))
19730       allocate(Ug2DtEUg(2,2,nres))
19731 !(2,2,maxres)
19732       allocate(Ug2DtEUgder(2,2,2,nres))
19733       allocate(DtUg2EUgder(2,2,2,nres))
19734 !(2,2,2,maxres)
19735 !      common /rotat_old/
19736       allocate(costab(nres))
19737       allocate(sintab(nres))
19738       allocate(costab2(nres))
19739       allocate(sintab2(nres))
19740 !(maxres)
19741 !      common /dipmat/
19742       allocate(a_chuj(2,2,maxconts,nres))
19743 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19744       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19745 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19746 !      common /contdistrib/
19747       allocate(ncont_sent(nres))
19748       allocate(ncont_recv(nres))
19749
19750       allocate(iat_sent(nres))
19751 !(maxres)
19752       allocate(iint_sent(4,nres,nres))
19753       allocate(iint_sent_local(4,nres,nres))
19754 !(4,maxres,maxres)
19755       allocate(iturn3_sent(4,0:nres+4))
19756       allocate(iturn4_sent(4,0:nres+4))
19757       allocate(iturn3_sent_local(4,nres))
19758       allocate(iturn4_sent_local(4,nres))
19759 !(4,maxres)
19760       allocate(itask_cont_from(0:nfgtasks-1))
19761       allocate(itask_cont_to(0:nfgtasks-1))
19762 !(0:max_fg_procs-1)
19763
19764
19765
19766 !----------------------
19767 ! commom.deriv;
19768 !      common /derivat/
19769       allocate(dcdv(6,maxdim))
19770       allocate(dxdv(6,maxdim))
19771 !(6,maxdim)
19772       allocate(dxds(6,nres))
19773 !(6,maxres)
19774       allocate(gradx(3,-1:nres,0:2))
19775       allocate(gradc(3,-1:nres,0:2))
19776 !(3,maxres,2)
19777       allocate(gvdwx(3,-1:nres))
19778       allocate(gvdwc(3,-1:nres))
19779       allocate(gelc(3,-1:nres))
19780       allocate(gelc_long(3,-1:nres))
19781       allocate(gvdwpp(3,-1:nres))
19782       allocate(gvdwc_scpp(3,-1:nres))
19783       allocate(gradx_scp(3,-1:nres))
19784       allocate(gvdwc_scp(3,-1:nres))
19785       allocate(ghpbx(3,-1:nres))
19786       allocate(ghpbc(3,-1:nres))
19787       allocate(gradcorr(3,-1:nres))
19788       allocate(gradcorr_long(3,-1:nres))
19789       allocate(gradcorr5_long(3,-1:nres))
19790       allocate(gradcorr6_long(3,-1:nres))
19791       allocate(gcorr6_turn_long(3,-1:nres))
19792       allocate(gradxorr(3,-1:nres))
19793       allocate(gradcorr5(3,-1:nres))
19794       allocate(gradcorr6(3,-1:nres))
19795       allocate(gliptran(3,-1:nres))
19796       allocate(gliptranc(3,-1:nres))
19797       allocate(gliptranx(3,-1:nres))
19798       allocate(gshieldx(3,-1:nres))
19799       allocate(gshieldc(3,-1:nres))
19800       allocate(gshieldc_loc(3,-1:nres))
19801       allocate(gshieldx_ec(3,-1:nres))
19802       allocate(gshieldc_ec(3,-1:nres))
19803       allocate(gshieldc_loc_ec(3,-1:nres))
19804       allocate(gshieldx_t3(3,-1:nres))
19805       allocate(gshieldc_t3(3,-1:nres))
19806       allocate(gshieldc_loc_t3(3,-1:nres))
19807       allocate(gshieldx_t4(3,-1:nres))
19808       allocate(gshieldc_t4(3,-1:nres))
19809       allocate(gshieldc_loc_t4(3,-1:nres))
19810       allocate(gshieldx_ll(3,-1:nres))
19811       allocate(gshieldc_ll(3,-1:nres))
19812       allocate(gshieldc_loc_ll(3,-1:nres))
19813       allocate(grad_shield(3,-1:nres))
19814       allocate(gg_tube_sc(3,-1:nres))
19815       allocate(gg_tube(3,-1:nres))
19816       allocate(gradafm(3,-1:nres))
19817       allocate(gradb_nucl(3,-1:nres))
19818       allocate(gradbx_nucl(3,-1:nres))
19819       allocate(gvdwpsb1(3,-1:nres))
19820       allocate(gelpp(3,-1:nres))
19821       allocate(gvdwpsb(3,-1:nres))
19822       allocate(gelsbc(3,-1:nres))
19823       allocate(gelsbx(3,-1:nres))
19824       allocate(gvdwsbx(3,-1:nres))
19825       allocate(gvdwsbc(3,-1:nres))
19826       allocate(gsbloc(3,-1:nres))
19827       allocate(gsblocx(3,-1:nres))
19828       allocate(gradcorr_nucl(3,-1:nres))
19829       allocate(gradxorr_nucl(3,-1:nres))
19830       allocate(gradcorr3_nucl(3,-1:nres))
19831       allocate(gradxorr3_nucl(3,-1:nres))
19832       allocate(gvdwpp_nucl(3,-1:nres))
19833       allocate(gradpepcat(3,-1:nres))
19834       allocate(gradpepcatx(3,-1:nres))
19835       allocate(gradcatcat(3,-1:nres))
19836 !(3,maxres)
19837       allocate(grad_shield_side(3,50,nres))
19838       allocate(grad_shield_loc(3,50,nres))
19839 ! grad for shielding surroing
19840       allocate(gloc(0:maxvar,0:2))
19841       allocate(gloc_x(0:maxvar,2))
19842 !(maxvar,2)
19843       allocate(gel_loc(3,-1:nres))
19844       allocate(gel_loc_long(3,-1:nres))
19845       allocate(gcorr3_turn(3,-1:nres))
19846       allocate(gcorr4_turn(3,-1:nres))
19847       allocate(gcorr6_turn(3,-1:nres))
19848       allocate(gradb(3,-1:nres))
19849       allocate(gradbx(3,-1:nres))
19850 !(3,maxres)
19851       allocate(gel_loc_loc(maxvar))
19852       allocate(gel_loc_turn3(maxvar))
19853       allocate(gel_loc_turn4(maxvar))
19854       allocate(gel_loc_turn6(maxvar))
19855       allocate(gcorr_loc(maxvar))
19856       allocate(g_corr5_loc(maxvar))
19857       allocate(g_corr6_loc(maxvar))
19858 !(maxvar)
19859       allocate(gsccorc(3,-1:nres))
19860       allocate(gsccorx(3,-1:nres))
19861 !(3,maxres)
19862       allocate(gsccor_loc(-1:nres))
19863 !(maxres)
19864       allocate(gvdwx_scbase(3,-1:nres))
19865       allocate(gvdwc_scbase(3,-1:nres))
19866       allocate(gvdwx_pepbase(3,-1:nres))
19867       allocate(gvdwc_pepbase(3,-1:nres))
19868       allocate(gvdwx_scpho(3,-1:nres))
19869       allocate(gvdwc_scpho(3,-1:nres))
19870       allocate(gvdwc_peppho(3,-1:nres))
19871
19872       allocate(dtheta(3,2,-1:nres))
19873 !(3,2,maxres)
19874       allocate(gscloc(3,-1:nres))
19875       allocate(gsclocx(3,-1:nres))
19876 !(3,maxres)
19877       allocate(dphi(3,3,-1:nres))
19878       allocate(dalpha(3,3,-1:nres))
19879       allocate(domega(3,3,-1:nres))
19880 !(3,3,maxres)
19881 !      common /deriv_scloc/
19882       allocate(dXX_C1tab(3,nres))
19883       allocate(dYY_C1tab(3,nres))
19884       allocate(dZZ_C1tab(3,nres))
19885       allocate(dXX_Ctab(3,nres))
19886       allocate(dYY_Ctab(3,nres))
19887       allocate(dZZ_Ctab(3,nres))
19888       allocate(dXX_XYZtab(3,nres))
19889       allocate(dYY_XYZtab(3,nres))
19890       allocate(dZZ_XYZtab(3,nres))
19891 !(3,maxres)
19892 !      common /mpgrad/
19893       allocate(jgrad_start(nres))
19894       allocate(jgrad_end(nres))
19895 !(maxres)
19896 !----------------------
19897
19898 !      common /indices/
19899       allocate(ibond_displ(0:nfgtasks-1))
19900       allocate(ibond_count(0:nfgtasks-1))
19901       allocate(ithet_displ(0:nfgtasks-1))
19902       allocate(ithet_count(0:nfgtasks-1))
19903       allocate(iphi_displ(0:nfgtasks-1))
19904       allocate(iphi_count(0:nfgtasks-1))
19905       allocate(iphi1_displ(0:nfgtasks-1))
19906       allocate(iphi1_count(0:nfgtasks-1))
19907       allocate(ivec_displ(0:nfgtasks-1))
19908       allocate(ivec_count(0:nfgtasks-1))
19909       allocate(iset_displ(0:nfgtasks-1))
19910       allocate(iset_count(0:nfgtasks-1))
19911       allocate(iint_count(0:nfgtasks-1))
19912       allocate(iint_displ(0:nfgtasks-1))
19913 !(0:max_fg_procs-1)
19914 !----------------------
19915 ! common.MD
19916 !      common /mdgrad/
19917       allocate(gcart(3,-1:nres))
19918       allocate(gxcart(3,-1:nres))
19919 !(3,0:MAXRES)
19920       allocate(gradcag(3,-1:nres))
19921       allocate(gradxag(3,-1:nres))
19922 !(3,MAXRES)
19923 !      common /back_constr/
19924 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19925       allocate(dutheta(nres))
19926       allocate(dugamma(nres))
19927 !(maxres)
19928       allocate(duscdiff(3,nres))
19929       allocate(duscdiffx(3,nres))
19930 !(3,maxres)
19931 !el i io:read_fragments
19932 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19933 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19934 !      common /qmeas/
19935 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19936 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19937       allocate(mset(0:nprocs))  !(maxprocs/20)
19938       mset(:)=0
19939 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19940 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19941       allocate(dUdconst(3,0:nres))
19942       allocate(dUdxconst(3,0:nres))
19943       allocate(dqwol(3,0:nres))
19944       allocate(dxqwol(3,0:nres))
19945 !(3,0:MAXRES)
19946 !----------------------
19947 ! common.sbridge
19948 !      common /sbridge/ in io_common: read_bridge
19949 !el    allocate((:),allocatable :: iss      !(maxss)
19950 !      common /links/  in io_common: read_bridge
19951 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19952 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19953 !      common /dyn_ssbond/
19954 ! and side-chain vectors in theta or phi.
19955       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19956 !(maxres,maxres)
19957 !      do i=1,nres
19958 !        do j=i+1,nres
19959       dyn_ssbond_ij(:,:)=1.0d300
19960 !        enddo
19961 !      enddo
19962
19963 !      if (nss.gt.0) then
19964         allocate(idssb(maxdim),jdssb(maxdim))
19965 !        allocate(newihpb(nss),newjhpb(nss))
19966 !(maxdim)
19967 !      endif
19968       allocate(ishield_list(nres))
19969       allocate(shield_list(50,nres))
19970       allocate(dyn_ss_mask(nres))
19971       allocate(fac_shield(nres))
19972       allocate(enetube(nres*2))
19973       allocate(enecavtube(nres*2))
19974
19975 !(maxres)
19976       dyn_ss_mask(:)=.false.
19977 !----------------------
19978 ! common.sccor
19979 ! Parameters of the SCCOR term
19980 !      common/sccor/
19981 !el in io_conf: parmread
19982 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19983 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19984 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19985 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19986 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19987 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19988 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19989 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19990 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
19991 !----------------
19992       allocate(gloc_sc(3,0:2*nres,0:10))
19993 !(3,0:maxres2,10)maxres2=2*maxres
19994       allocate(dcostau(3,3,3,2*nres))
19995       allocate(dsintau(3,3,3,2*nres))
19996       allocate(dtauangle(3,3,3,2*nres))
19997       allocate(dcosomicron(3,3,3,2*nres))
19998       allocate(domicron(3,3,3,2*nres))
19999 !(3,3,3,maxres2)maxres2=2*maxres
20000 !----------------------
20001 ! common.var
20002 !      common /restr/
20003       allocate(varall(maxvar))
20004 !(maxvar)(maxvar=6*maxres)
20005       allocate(mask_theta(nres))
20006       allocate(mask_phi(nres))
20007       allocate(mask_side(nres))
20008 !(maxres)
20009 !----------------------
20010 ! common.vectors
20011 !      common /vectors/
20012       allocate(uy(3,nres))
20013       allocate(uz(3,nres))
20014 !(3,maxres)
20015       allocate(uygrad(3,3,2,nres))
20016       allocate(uzgrad(3,3,2,nres))
20017 !(3,3,2,maxres)
20018
20019       return
20020       end subroutine alloc_ener_arrays
20021 !-----------------------------------------------------------------
20022       subroutine ebond_nucl(estr_nucl)
20023 !c
20024 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20025 !c
20026
20027       real(kind=8),dimension(3) :: u,ud
20028       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20029       real(kind=8) :: estr_nucl,diff
20030       integer :: iti,i,j,k,nbi
20031       estr_nucl=0.0d0
20032 !C      print *,"I enter ebond"
20033       if (energy_dec) &
20034       write (iout,*) "ibondp_start,ibondp_end",&
20035        ibondp_nucl_start,ibondp_nucl_end
20036       do i=ibondp_nucl_start,ibondp_nucl_end
20037         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20038          itype(i,2).eq.ntyp1_molec(2)) cycle
20039 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20040 !          do j=1,3
20041 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20042 !     &      *dc(j,i-1)/vbld(i)
20043 !          enddo
20044 !          if (energy_dec) write(iout,*)
20045 !     &       "estr1",i,vbld(i),distchainmax,
20046 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20047
20048           diff = vbld(i)-vbldp0_nucl
20049           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20050           vbldp0_nucl,diff,AKP_nucl*diff*diff
20051           estr_nucl=estr_nucl+diff*diff
20052 !          print *,estr_nucl
20053           do j=1,3
20054             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20055           enddo
20056 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20057       enddo
20058       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20059 !      print *,"partial sum", estr_nucl,AKP_nucl
20060
20061       if (energy_dec) &
20062       write (iout,*) "ibondp_start,ibondp_end",&
20063        ibond_nucl_start,ibond_nucl_end
20064
20065       do i=ibond_nucl_start,ibond_nucl_end
20066 !C        print *, "I am stuck",i
20067         iti=itype(i,2)
20068         if (iti.eq.ntyp1_molec(2)) cycle
20069           nbi=nbondterm_nucl(iti)
20070 !C        print *,iti,nbi
20071           if (nbi.eq.1) then
20072             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20073
20074             if (energy_dec) &
20075            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20076            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20077             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20078 !            print *,estr_nucl
20079             do j=1,3
20080               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20081             enddo
20082           else
20083             do j=1,nbi
20084               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20085               ud(j)=aksc_nucl(j,iti)*diff
20086               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20087             enddo
20088             uprod=u(1)
20089             do j=2,nbi
20090               uprod=uprod*u(j)
20091             enddo
20092             usum=0.0d0
20093             usumsqder=0.0d0
20094             do j=1,nbi
20095               uprod1=1.0d0
20096               uprod2=1.0d0
20097               do k=1,nbi
20098                 if (k.ne.j) then
20099                   uprod1=uprod1*u(k)
20100                   uprod2=uprod2*u(k)*u(k)
20101                 endif
20102               enddo
20103               usum=usum+uprod1
20104               usumsqder=usumsqder+ud(j)*uprod2
20105             enddo
20106             estr_nucl=estr_nucl+uprod/usum
20107             do j=1,3
20108              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20109             enddo
20110         endif
20111       enddo
20112 !C      print *,"I am about to leave ebond"
20113       return
20114       end subroutine ebond_nucl
20115
20116 !-----------------------------------------------------------------------------
20117       subroutine ebend_nucl(etheta_nucl)
20118       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20119       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20120       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20121       logical :: lprn=.false., lprn1=.false.
20122 !el local variables
20123       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20124       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20125       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20126 ! local variables for constrains
20127       real(kind=8) :: difi,thetiii
20128        integer itheta
20129       etheta_nucl=0.0D0
20130 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20131       do i=ithet_nucl_start,ithet_nucl_end
20132         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20133         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20134         (itype(i,2).eq.ntyp1_molec(2))) cycle
20135         dethetai=0.0d0
20136         dephii=0.0d0
20137         dephii1=0.0d0
20138         theti2=0.5d0*theta(i)
20139         ityp2=ithetyp_nucl(itype(i-1,2))
20140         do k=1,nntheterm_nucl
20141           coskt(k)=dcos(k*theti2)
20142           sinkt(k)=dsin(k*theti2)
20143         enddo
20144         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20145 #ifdef OSF
20146           phii=phi(i)
20147           if (phii.ne.phii) phii=150.0
20148 #else
20149           phii=phi(i)
20150 #endif
20151           ityp1=ithetyp_nucl(itype(i-2,2))
20152           do k=1,nsingle_nucl
20153             cosph1(k)=dcos(k*phii)
20154             sinph1(k)=dsin(k*phii)
20155           enddo
20156         else
20157           phii=0.0d0
20158           ityp1=nthetyp_nucl+1
20159           do k=1,nsingle_nucl
20160             cosph1(k)=0.0d0
20161             sinph1(k)=0.0d0
20162           enddo
20163         endif
20164
20165         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20166 #ifdef OSF
20167           phii1=phi(i+1)
20168           if (phii1.ne.phii1) phii1=150.0
20169           phii1=pinorm(phii1)
20170 #else
20171           phii1=phi(i+1)
20172 #endif
20173           ityp3=ithetyp_nucl(itype(i,2))
20174           do k=1,nsingle_nucl
20175             cosph2(k)=dcos(k*phii1)
20176             sinph2(k)=dsin(k*phii1)
20177           enddo
20178         else
20179           phii1=0.0d0
20180           ityp3=nthetyp_nucl+1
20181           do k=1,nsingle_nucl
20182             cosph2(k)=0.0d0
20183             sinph2(k)=0.0d0
20184           enddo
20185         endif
20186         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20187         do k=1,ndouble_nucl
20188           do l=1,k-1
20189             ccl=cosph1(l)*cosph2(k-l)
20190             ssl=sinph1(l)*sinph2(k-l)
20191             scl=sinph1(l)*cosph2(k-l)
20192             csl=cosph1(l)*sinph2(k-l)
20193             cosph1ph2(l,k)=ccl-ssl
20194             cosph1ph2(k,l)=ccl+ssl
20195             sinph1ph2(l,k)=scl+csl
20196             sinph1ph2(k,l)=scl-csl
20197           enddo
20198         enddo
20199         if (lprn) then
20200         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20201          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20202         write (iout,*) "coskt and sinkt",nntheterm_nucl
20203         do k=1,nntheterm_nucl
20204           write (iout,*) k,coskt(k),sinkt(k)
20205         enddo
20206         endif
20207         do k=1,ntheterm_nucl
20208           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20209           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20210            *coskt(k)
20211           if (lprn)&
20212          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20213           " ethetai",ethetai
20214         enddo
20215         if (lprn) then
20216         write (iout,*) "cosph and sinph"
20217         do k=1,nsingle_nucl
20218           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20219         enddo
20220         write (iout,*) "cosph1ph2 and sinph2ph2"
20221         do k=2,ndouble_nucl
20222           do l=1,k-1
20223             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20224               sinph1ph2(l,k),sinph1ph2(k,l)
20225           enddo
20226         enddo
20227         write(iout,*) "ethetai",ethetai
20228         endif
20229         do m=1,ntheterm2_nucl
20230           do k=1,nsingle_nucl
20231             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20232               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20233               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20234               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20235             ethetai=ethetai+sinkt(m)*aux
20236             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20237             dephii=dephii+k*sinkt(m)*(&
20238                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20239                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20240             dephii1=dephii1+k*sinkt(m)*(&
20241                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20242                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20243             if (lprn) &
20244            write (iout,*) "m",m," k",k," bbthet",&
20245               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20246               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20247               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20248               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20249           enddo
20250         enddo
20251         if (lprn) &
20252         write(iout,*) "ethetai",ethetai
20253         do m=1,ntheterm3_nucl
20254           do k=2,ndouble_nucl
20255             do l=1,k-1
20256               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20257                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20258                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20259                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20260               ethetai=ethetai+sinkt(m)*aux
20261               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20262               dephii=dephii+l*sinkt(m)*(&
20263                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20264                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20265                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20266                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20267               dephii1=dephii1+(k-l)*sinkt(m)*( &
20268                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20269                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20270                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20271                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20272               if (lprn) then
20273               write (iout,*) "m",m," k",k," l",l," ffthet", &
20274                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20275                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20276                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20277                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20278               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20279                  cosph1ph2(k,l)*sinkt(m),&
20280                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20281               endif
20282             enddo
20283           enddo
20284         enddo
20285 10      continue
20286         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20287         i,theta(i)*rad2deg,phii*rad2deg, &
20288         phii1*rad2deg,ethetai
20289         etheta_nucl=etheta_nucl+ethetai
20290 !        print *,i,"partial sum",etheta_nucl
20291         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20292         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20293         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20294       enddo
20295       return
20296       end subroutine ebend_nucl
20297 !----------------------------------------------------
20298       subroutine etor_nucl(etors_nucl)
20299 !      implicit real*8 (a-h,o-z)
20300 !      include 'DIMENSIONS'
20301 !      include 'COMMON.VAR'
20302 !      include 'COMMON.GEO'
20303 !      include 'COMMON.LOCAL'
20304 !      include 'COMMON.TORSION'
20305 !      include 'COMMON.INTERACT'
20306 !      include 'COMMON.DERIV'
20307 !      include 'COMMON.CHAIN'
20308 !      include 'COMMON.NAMES'
20309 !      include 'COMMON.IOUNITS'
20310 !      include 'COMMON.FFIELD'
20311 !      include 'COMMON.TORCNSTR'
20312 !      include 'COMMON.CONTROL'
20313       real(kind=8) :: etors_nucl,edihcnstr
20314       logical :: lprn
20315 !el local variables
20316       integer :: i,j,iblock,itori,itori1
20317       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20318                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20319 ! Set lprn=.true. for debugging
20320       lprn=.false.
20321 !     lprn=.true.
20322       etors_nucl=0.0D0
20323 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20324       do i=iphi_nucl_start,iphi_nucl_end
20325         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20326              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20327              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20328         etors_ii=0.0D0
20329         itori=itortyp_nucl(itype(i-2,2))
20330         itori1=itortyp_nucl(itype(i-1,2))
20331         phii=phi(i)
20332 !         print *,i,itori,itori1
20333         gloci=0.0D0
20334 !C Regular cosine and sine terms
20335         do j=1,nterm_nucl(itori,itori1)
20336           v1ij=v1_nucl(j,itori,itori1)
20337           v2ij=v2_nucl(j,itori,itori1)
20338           cosphi=dcos(j*phii)
20339           sinphi=dsin(j*phii)
20340           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20341           if (energy_dec) etors_ii=etors_ii+&
20342                      v1ij*cosphi+v2ij*sinphi
20343           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20344         enddo
20345 !C Lorentz terms
20346 !C                         v1
20347 !C  E = SUM ----------------------------------- - v1
20348 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20349 !C
20350         cosphi=dcos(0.5d0*phii)
20351         sinphi=dsin(0.5d0*phii)
20352         do j=1,nlor_nucl(itori,itori1)
20353           vl1ij=vlor1_nucl(j,itori,itori1)
20354           vl2ij=vlor2_nucl(j,itori,itori1)
20355           vl3ij=vlor3_nucl(j,itori,itori1)
20356           pom=vl2ij*cosphi+vl3ij*sinphi
20357           pom1=1.0d0/(pom*pom+1.0d0)
20358           etors_nucl=etors_nucl+vl1ij*pom1
20359           if (energy_dec) etors_ii=etors_ii+ &
20360                      vl1ij*pom1
20361           pom=-pom*pom1*pom1
20362           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20363         enddo
20364 !C Subtract the constant term
20365         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20366           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20367               'etor',i,etors_ii-v0_nucl(itori,itori1)
20368         if (lprn) &
20369        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20370        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20371        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20372         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20373 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20374       enddo
20375       return
20376       end subroutine etor_nucl
20377 !------------------------------------------------------------
20378       subroutine epp_nucl_sub(evdw1,ees)
20379 !C
20380 !C This subroutine calculates the average interaction energy and its gradient
20381 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20382 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20383 !C The potential depends both on the distance of peptide-group centers and on
20384 !C the orientation of the CA-CA virtual bonds.
20385 !C
20386       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20387       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20388       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20389                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20390                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20391       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20392                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20393       integer xshift,yshift,zshift
20394       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20395       real(kind=8) :: ees,eesij
20396 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20397       real(kind=8) scal_el /0.5d0/
20398       t_eelecij=0.0d0
20399       ees=0.0D0
20400       evdw1=0.0D0
20401       ind=0
20402 !c
20403 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20404 !c
20405 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20406       do i=iatel_s_nucl,iatel_e_nucl
20407         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20408         dxi=dc(1,i)
20409         dyi=dc(2,i)
20410         dzi=dc(3,i)
20411         dx_normi=dc_norm(1,i)
20412         dy_normi=dc_norm(2,i)
20413         dz_normi=dc_norm(3,i)
20414         xmedi=c(1,i)+0.5d0*dxi
20415         ymedi=c(2,i)+0.5d0*dyi
20416         zmedi=c(3,i)+0.5d0*dzi
20417           xmedi=dmod(xmedi,boxxsize)
20418           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20419           ymedi=dmod(ymedi,boxysize)
20420           if (ymedi.lt.0) ymedi=ymedi+boxysize
20421           zmedi=dmod(zmedi,boxzsize)
20422           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20423
20424         do j=ielstart_nucl(i),ielend_nucl(i)
20425           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20426           ind=ind+1
20427           dxj=dc(1,j)
20428           dyj=dc(2,j)
20429           dzj=dc(3,j)
20430 !          xj=c(1,j)+0.5D0*dxj-xmedi
20431 !          yj=c(2,j)+0.5D0*dyj-ymedi
20432 !          zj=c(3,j)+0.5D0*dzj-zmedi
20433           xj=c(1,j)+0.5D0*dxj
20434           yj=c(2,j)+0.5D0*dyj
20435           zj=c(3,j)+0.5D0*dzj
20436           xj=mod(xj,boxxsize)
20437           if (xj.lt.0) xj=xj+boxxsize
20438           yj=mod(yj,boxysize)
20439           if (yj.lt.0) yj=yj+boxysize
20440           zj=mod(zj,boxzsize)
20441           if (zj.lt.0) zj=zj+boxzsize
20442       isubchap=0
20443       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20444       xj_safe=xj
20445       yj_safe=yj
20446       zj_safe=zj
20447       do xshift=-1,1
20448       do yshift=-1,1
20449       do zshift=-1,1
20450           xj=xj_safe+xshift*boxxsize
20451           yj=yj_safe+yshift*boxysize
20452           zj=zj_safe+zshift*boxzsize
20453           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20454           if(dist_temp.lt.dist_init) then
20455             dist_init=dist_temp
20456             xj_temp=xj
20457             yj_temp=yj
20458             zj_temp=zj
20459             isubchap=1
20460           endif
20461        enddo
20462        enddo
20463        enddo
20464        if (isubchap.eq.1) then
20465 !C          print *,i,j
20466           xj=xj_temp-xmedi
20467           yj=yj_temp-ymedi
20468           zj=zj_temp-zmedi
20469        else
20470           xj=xj_safe-xmedi
20471           yj=yj_safe-ymedi
20472           zj=zj_safe-zmedi
20473        endif
20474
20475           rij=xj*xj+yj*yj+zj*zj
20476 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20477           fac=(r0pp**2/rij)**3
20478           ev1=epspp*fac*fac
20479           ev2=epspp*fac
20480           evdw1ij=ev1-2*ev2
20481           fac=(-ev1-evdw1ij)/rij
20482 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20483           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20484           evdw1=evdw1+evdw1ij
20485 !C
20486 !C Calculate contributions to the Cartesian gradient.
20487 !C
20488           ggg(1)=fac*xj
20489           ggg(2)=fac*yj
20490           ggg(3)=fac*zj
20491           do k=1,3
20492             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20493             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20494           enddo
20495 !c phoshate-phosphate electrostatic interactions
20496           rij=dsqrt(rij)
20497           fac=1.0d0/rij
20498           eesij=dexp(-BEES*rij)*fac
20499 !          write (2,*)"fac",fac," eesijpp",eesij
20500           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20501           ees=ees+eesij
20502 !c          fac=-eesij*fac
20503           fac=-(fac+BEES)*eesij*fac
20504           ggg(1)=fac*xj
20505           ggg(2)=fac*yj
20506           ggg(3)=fac*zj
20507 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20508 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20509 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20510           do k=1,3
20511             gelpp(k,i)=gelpp(k,i)-ggg(k)
20512             gelpp(k,j)=gelpp(k,j)+ggg(k)
20513           enddo
20514         enddo ! j
20515       enddo   ! i
20516 !c      ees=332.0d0*ees
20517       ees=AEES*ees
20518       do i=nnt,nct
20519 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20520         do k=1,3
20521           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20522 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20523           gelpp(k,i)=AEES*gelpp(k,i)
20524         enddo
20525 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20526       enddo
20527 !c      write (2,*) "total EES",ees
20528       return
20529       end subroutine epp_nucl_sub
20530 !---------------------------------------------------------------------
20531       subroutine epsb(evdwpsb,eelpsb)
20532 !      use comm_locel
20533 !C
20534 !C This subroutine calculates the excluded-volume interaction energy between
20535 !C peptide-group centers and side chains and its gradient in virtual-bond and
20536 !C side-chain vectors.
20537 !C
20538       real(kind=8),dimension(3):: ggg
20539       integer :: i,iint,j,k,iteli,itypj,subchap
20540       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20541                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20542       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20543                     dist_temp, dist_init
20544       integer xshift,yshift,zshift
20545
20546 !cd    print '(a)','Enter ESCP'
20547 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20548       eelpsb=0.0d0
20549       evdwpsb=0.0d0
20550 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20551       do i=iatscp_s_nucl,iatscp_e_nucl
20552         if (itype(i,2).eq.ntyp1_molec(2) &
20553          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20554         xi=0.5D0*(c(1,i)+c(1,i+1))
20555         yi=0.5D0*(c(2,i)+c(2,i+1))
20556         zi=0.5D0*(c(3,i)+c(3,i+1))
20557           xi=mod(xi,boxxsize)
20558           if (xi.lt.0) xi=xi+boxxsize
20559           yi=mod(yi,boxysize)
20560           if (yi.lt.0) yi=yi+boxysize
20561           zi=mod(zi,boxzsize)
20562           if (zi.lt.0) zi=zi+boxzsize
20563
20564         do iint=1,nscp_gr_nucl(i)
20565
20566         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20567           itypj=itype(j,2)
20568           if (itypj.eq.ntyp1_molec(2)) cycle
20569 !C Uncomment following three lines for SC-p interactions
20570 !c         xj=c(1,nres+j)-xi
20571 !c         yj=c(2,nres+j)-yi
20572 !c         zj=c(3,nres+j)-zi
20573 !C Uncomment following three lines for Ca-p interactions
20574 !          xj=c(1,j)-xi
20575 !          yj=c(2,j)-yi
20576 !          zj=c(3,j)-zi
20577           xj=c(1,j)
20578           yj=c(2,j)
20579           zj=c(3,j)
20580           xj=mod(xj,boxxsize)
20581           if (xj.lt.0) xj=xj+boxxsize
20582           yj=mod(yj,boxysize)
20583           if (yj.lt.0) yj=yj+boxysize
20584           zj=mod(zj,boxzsize)
20585           if (zj.lt.0) zj=zj+boxzsize
20586       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20587       xj_safe=xj
20588       yj_safe=yj
20589       zj_safe=zj
20590       subchap=0
20591       do xshift=-1,1
20592       do yshift=-1,1
20593       do zshift=-1,1
20594           xj=xj_safe+xshift*boxxsize
20595           yj=yj_safe+yshift*boxysize
20596           zj=zj_safe+zshift*boxzsize
20597           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20598           if(dist_temp.lt.dist_init) then
20599             dist_init=dist_temp
20600             xj_temp=xj
20601             yj_temp=yj
20602             zj_temp=zj
20603             subchap=1
20604           endif
20605        enddo
20606        enddo
20607        enddo
20608        if (subchap.eq.1) then
20609           xj=xj_temp-xi
20610           yj=yj_temp-yi
20611           zj=zj_temp-zi
20612        else
20613           xj=xj_safe-xi
20614           yj=yj_safe-yi
20615           zj=zj_safe-zi
20616        endif
20617
20618           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20619           fac=rrij**expon2
20620           e1=fac*fac*aad_nucl(itypj)
20621           e2=fac*bad_nucl(itypj)
20622           if (iabs(j-i) .le. 2) then
20623             e1=scal14*e1
20624             e2=scal14*e2
20625           endif
20626           evdwij=e1+e2
20627           evdwpsb=evdwpsb+evdwij
20628           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20629              'evdw2',i,j,evdwij,"tu4"
20630 !C
20631 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20632 !C
20633           fac=-(evdwij+e1)*rrij
20634           ggg(1)=xj*fac
20635           ggg(2)=yj*fac
20636           ggg(3)=zj*fac
20637           do k=1,3
20638             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20639             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20640           enddo
20641         enddo
20642
20643         enddo ! iint
20644       enddo ! i
20645       do i=1,nct
20646         do j=1,3
20647           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20648           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20649         enddo
20650       enddo
20651       return
20652       end subroutine epsb
20653
20654 !------------------------------------------------------
20655       subroutine esb_gb(evdwsb,eelsb)
20656       use comm_locel
20657       use calc_data_nucl
20658       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20659       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20660       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20661       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20662                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20663       integer :: ii
20664       logical lprn
20665       evdw=0.0D0
20666       eelsb=0.0d0
20667       ecorr=0.0d0
20668       evdwsb=0.0D0
20669       lprn=.false.
20670       ind=0
20671 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20672       do i=iatsc_s_nucl,iatsc_e_nucl
20673         num_conti=0
20674         num_conti2=0
20675         itypi=itype(i,2)
20676 !        PRINT *,"I=",i,itypi
20677         if (itypi.eq.ntyp1_molec(2)) cycle
20678         itypi1=itype(i+1,2)
20679         xi=c(1,nres+i)
20680         yi=c(2,nres+i)
20681         zi=c(3,nres+i)
20682           xi=dmod(xi,boxxsize)
20683           if (xi.lt.0) xi=xi+boxxsize
20684           yi=dmod(yi,boxysize)
20685           if (yi.lt.0) yi=yi+boxysize
20686           zi=dmod(zi,boxzsize)
20687           if (zi.lt.0) zi=zi+boxzsize
20688
20689         dxi=dc_norm(1,nres+i)
20690         dyi=dc_norm(2,nres+i)
20691         dzi=dc_norm(3,nres+i)
20692         dsci_inv=vbld_inv(i+nres)
20693 !C
20694 !C Calculate SC interaction energy.
20695 !C
20696         do iint=1,nint_gr_nucl(i)
20697 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20698           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20699             ind=ind+1
20700 !            print *,"JESTEM"
20701             itypj=itype(j,2)
20702             if (itypj.eq.ntyp1_molec(2)) cycle
20703             dscj_inv=vbld_inv(j+nres)
20704             sig0ij=sigma_nucl(itypi,itypj)
20705             chi1=chi_nucl(itypi,itypj)
20706             chi2=chi_nucl(itypj,itypi)
20707             chi12=chi1*chi2
20708             chip1=chip_nucl(itypi,itypj)
20709             chip2=chip_nucl(itypj,itypi)
20710             chip12=chip1*chip2
20711 !            xj=c(1,nres+j)-xi
20712 !            yj=c(2,nres+j)-yi
20713 !            zj=c(3,nres+j)-zi
20714            xj=c(1,nres+j)
20715            yj=c(2,nres+j)
20716            zj=c(3,nres+j)
20717           xj=dmod(xj,boxxsize)
20718           if (xj.lt.0) xj=xj+boxxsize
20719           yj=dmod(yj,boxysize)
20720           if (yj.lt.0) yj=yj+boxysize
20721           zj=dmod(zj,boxzsize)
20722           if (zj.lt.0) zj=zj+boxzsize
20723       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20724       xj_safe=xj
20725       yj_safe=yj
20726       zj_safe=zj
20727       subchap=0
20728       do xshift=-1,1
20729       do yshift=-1,1
20730       do zshift=-1,1
20731           xj=xj_safe+xshift*boxxsize
20732           yj=yj_safe+yshift*boxysize
20733           zj=zj_safe+zshift*boxzsize
20734           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20735           if(dist_temp.lt.dist_init) then
20736             dist_init=dist_temp
20737             xj_temp=xj
20738             yj_temp=yj
20739             zj_temp=zj
20740             subchap=1
20741           endif
20742        enddo
20743        enddo
20744        enddo
20745        if (subchap.eq.1) then
20746           xj=xj_temp-xi
20747           yj=yj_temp-yi
20748           zj=zj_temp-zi
20749        else
20750           xj=xj_safe-xi
20751           yj=yj_safe-yi
20752           zj=zj_safe-zi
20753        endif
20754
20755             dxj=dc_norm(1,nres+j)
20756             dyj=dc_norm(2,nres+j)
20757             dzj=dc_norm(3,nres+j)
20758             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20759             rij=dsqrt(rrij)
20760 !C Calculate angle-dependent terms of energy and contributions to their
20761 !C derivatives.
20762             erij(1)=xj*rij
20763             erij(2)=yj*rij
20764             erij(3)=zj*rij
20765             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20766             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20767             om12=dxi*dxj+dyi*dyj+dzi*dzj
20768             call sc_angular_nucl
20769             sigsq=1.0D0/sigsq
20770             sig=sig0ij*dsqrt(sigsq)
20771             rij_shift=1.0D0/rij-sig+sig0ij
20772 !            print *,rij_shift,"rij_shift"
20773 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20774 !c     &       " rij_shift",rij_shift
20775             if (rij_shift.le.0.0D0) then
20776               evdw=1.0D20
20777               return
20778             endif
20779             sigder=-sig*sigsq
20780 !c---------------------------------------------------------------
20781             rij_shift=1.0D0/rij_shift
20782             fac=rij_shift**expon
20783             e1=fac*fac*aa_nucl(itypi,itypj)
20784             e2=fac*bb_nucl(itypi,itypj)
20785             evdwij=eps1*eps2rt*(e1+e2)
20786 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20787 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20788             eps2der=evdwij
20789             evdwij=evdwij*eps2rt
20790             evdwsb=evdwsb+evdwij
20791             if (lprn) then
20792             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
20793             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
20794             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20795              restyp(itypi,2),i,restyp(itypj,2),j, &
20796              epsi,sigm,chi1,chi2,chip1,chip2, &
20797              eps1,eps2rt**2,sig,sig0ij, &
20798              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20799             evdwij
20800             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20801             endif
20802
20803             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20804                              'evdw',i,j,evdwij,"tu3"
20805
20806
20807 !C Calculate gradient components.
20808             e1=e1*eps1*eps2rt**2
20809             fac=-expon*(e1+evdwij)*rij_shift
20810             sigder=fac*sigder
20811             fac=rij*fac
20812 !c            fac=0.0d0
20813 !C Calculate the radial part of the gradient
20814             gg(1)=xj*fac
20815             gg(2)=yj*fac
20816             gg(3)=zj*fac
20817 !C Calculate angular part of the gradient.
20818             call sc_grad_nucl
20819             call eelsbij(eelij,num_conti2)
20820             if (energy_dec .and. &
20821            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20822           write (istat,'(e14.5)') evdwij
20823             eelsb=eelsb+eelij
20824           enddo      ! j
20825         enddo        ! iint
20826         num_cont_hb(i)=num_conti2
20827       enddo          ! i
20828 !c      write (iout,*) "Number of loop steps in EGB:",ind
20829 !cccc      energy_dec=.false.
20830       return
20831       end subroutine esb_gb
20832 !-------------------------------------------------------------------------------
20833       subroutine eelsbij(eesij,num_conti2)
20834       use comm_locel
20835       use calc_data_nucl
20836       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20837       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20838       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20839                     dist_temp, dist_init,rlocshield,fracinbuf
20840       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20841
20842 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20843       real(kind=8) scal_el /0.5d0/
20844       integer :: iteli,itelj,kkk,kkll,m,isubchap
20845       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20846       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20847       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20848                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20849                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20850                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20851                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20852                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20853                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20854                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20855       ind=ind+1
20856       itypi=itype(i,2)
20857       itypj=itype(j,2)
20858 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20859       ael6i=ael6_nucl(itypi,itypj)
20860       ael3i=ael3_nucl(itypi,itypj)
20861       ael63i=ael63_nucl(itypi,itypj)
20862       ael32i=ael32_nucl(itypi,itypj)
20863 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20864 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20865       dxj=dc(1,j+nres)
20866       dyj=dc(2,j+nres)
20867       dzj=dc(3,j+nres)
20868       dx_normi=dc_norm(1,i+nres)
20869       dy_normi=dc_norm(2,i+nres)
20870       dz_normi=dc_norm(3,i+nres)
20871       dx_normj=dc_norm(1,j+nres)
20872       dy_normj=dc_norm(2,j+nres)
20873       dz_normj=dc_norm(3,j+nres)
20874 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20875 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20876 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20877       if (ipot_nucl.ne.2) then
20878         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20879         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20880         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20881       else
20882         cosa=om12
20883         cosb=om1
20884         cosg=om2
20885       endif
20886       r3ij=rij*rrij
20887       r6ij=r3ij*r3ij
20888       fac=cosa-3.0D0*cosb*cosg
20889       facfac=fac*fac
20890       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20891       fac3=ael6i*r6ij
20892       fac4=ael3i*r3ij
20893       fac5=ael63i*r6ij
20894       fac6=ael32i*r6ij
20895 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20896 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20897       el1=fac3*(4.0D0+facfac-fac1)
20898       el2=fac4*fac
20899       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20900       el4=fac6*facfac
20901       eesij=el1+el2+el3+el4
20902 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20903       ees0ij=4.0D0+facfac-fac1
20904
20905       if (energy_dec) then
20906           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20907           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20908            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20909            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20910            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20911           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20912       endif
20913
20914 !C
20915 !C Calculate contributions to the Cartesian gradient.
20916 !C
20917       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20918       fac1=fac
20919 !c      erij(1)=xj*rmij
20920 !c      erij(2)=yj*rmij
20921 !c      erij(3)=zj*rmij
20922 !*
20923 !* Radial derivatives. First process both termini of the fragment (i,j)
20924 !*
20925       ggg(1)=facel*xj
20926       ggg(2)=facel*yj
20927       ggg(3)=facel*zj
20928       do k=1,3
20929         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20930         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20931         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20932         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20933       enddo
20934 !*
20935 !* Angular part
20936 !*
20937       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20938       fac4=-3.0D0*fac4
20939       fac3=-6.0D0*fac3
20940       fac5= 6.0d0*fac5
20941       fac6=-6.0d0*fac6
20942       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20943        fac6*fac1*cosg
20944       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20945        fac6*fac1*cosb
20946       do k=1,3
20947         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20948         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20949       enddo
20950       do k=1,3
20951         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20952       enddo
20953       do k=1,3
20954         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20955              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20956              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20957         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20958              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20959              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20960         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20961         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20962       enddo
20963 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
20964        IF ( j.gt.i+1 .and.&
20965           num_conti.le.maxconts) THEN
20966 !C
20967 !C Calculate the contact function. The ith column of the array JCONT will
20968 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20969 !C greater than I). The arrays FACONT and GACONT will contain the values of
20970 !C the contact function and its derivative.
20971         r0ij=2.20D0*sigma(itypi,itypj)
20972 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20973         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20974 !c        write (2,*) "fcont",fcont
20975         if (fcont.gt.0.0D0) then
20976           num_conti=num_conti+1
20977           num_conti2=num_conti2+1
20978
20979           if (num_conti.gt.maxconts) then
20980             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20981                           ' will skip next contacts for this conf.'
20982           else
20983             jcont_hb(num_conti,i)=j
20984 !c            write (iout,*) "num_conti",num_conti,
20985 !c     &        " jcont_hb",jcont_hb(num_conti,i)
20986 !C Calculate contact energies
20987             cosa4=4.0D0*cosa
20988             wij=cosa-3.0D0*cosb*cosg
20989             cosbg1=cosb+cosg
20990             cosbg2=cosb-cosg
20991             fac3=dsqrt(-ael6i)*r3ij
20992 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
20993             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
20994             if (ees0tmp.gt.0) then
20995               ees0pij=dsqrt(ees0tmp)
20996             else
20997               ees0pij=0
20998             endif
20999             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21000             if (ees0tmp.gt.0) then
21001               ees0mij=dsqrt(ees0tmp)
21002             else
21003               ees0mij=0
21004             endif
21005             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21006             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21007 !c            write (iout,*) "i",i," j",j,
21008 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21009             ees0pij1=fac3/ees0pij
21010             ees0mij1=fac3/ees0mij
21011             fac3p=-3.0D0*fac3*rrij
21012             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21013             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21014             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21015             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21016             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21017             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21018             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21019             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21020             ecosap=ecosa1+ecosa2
21021             ecosbp=ecosb1+ecosb2
21022             ecosgp=ecosg1+ecosg2
21023             ecosam=ecosa1-ecosa2
21024             ecosbm=ecosb1-ecosb2
21025             ecosgm=ecosg1-ecosg2
21026 !C End diagnostics
21027             facont_hb(num_conti,i)=fcont
21028             fprimcont=fprimcont/rij
21029             do k=1,3
21030               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21031               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21032             enddo
21033             gggp(1)=gggp(1)+ees0pijp*xj
21034             gggp(2)=gggp(2)+ees0pijp*yj
21035             gggp(3)=gggp(3)+ees0pijp*zj
21036             gggm(1)=gggm(1)+ees0mijp*xj
21037             gggm(2)=gggm(2)+ees0mijp*yj
21038             gggm(3)=gggm(3)+ees0mijp*zj
21039 !C Derivatives due to the contact function
21040             gacont_hbr(1,num_conti,i)=fprimcont*xj
21041             gacont_hbr(2,num_conti,i)=fprimcont*yj
21042             gacont_hbr(3,num_conti,i)=fprimcont*zj
21043             do k=1,3
21044 !c
21045 !c Gradient of the correlation terms
21046 !c
21047               gacontp_hb1(k,num_conti,i)= &
21048              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21049             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21050               gacontp_hb2(k,num_conti,i)= &
21051              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21052             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21053               gacontp_hb3(k,num_conti,i)=gggp(k)
21054               gacontm_hb1(k,num_conti,i)= &
21055              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21056             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21057               gacontm_hb2(k,num_conti,i)= &
21058              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21059             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21060               gacontm_hb3(k,num_conti,i)=gggm(k)
21061             enddo
21062           endif
21063         endif
21064       ENDIF
21065       return
21066       end subroutine eelsbij
21067 !------------------------------------------------------------------
21068       subroutine sc_grad_nucl
21069       use comm_locel
21070       use calc_data_nucl
21071       real(kind=8),dimension(3) :: dcosom1,dcosom2
21072       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21073       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21074       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21075       do k=1,3
21076         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21077         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21078       enddo
21079       do k=1,3
21080         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21081       enddo
21082       do k=1,3
21083         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21084                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21085                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21086         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21087                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21088                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21089       enddo
21090 !C
21091 !C Calculate the components of the gradient in DC and X
21092 !C
21093       do l=1,3
21094         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21095         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21096       enddo
21097       return
21098       end subroutine sc_grad_nucl
21099 !-----------------------------------------------------------------------
21100       subroutine esb(esbloc)
21101 !C Calculate the local energy of a side chain and its derivatives in the
21102 !C corresponding virtual-bond valence angles THETA and the spherical angles
21103 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21104 !C added by Urszula Kozlowska. 07/11/2007
21105 !C
21106       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21107       real(kind=8),dimension(9):: x
21108      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21109       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21110       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21111       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21112        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21113        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21114        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21115        integer::it,nlobit,i,j,k
21116 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21117       delta=0.02d0*pi
21118       esbloc=0.0D0
21119       do i=loc_start_nucl,loc_end_nucl
21120         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21121         costtab(i+1) =dcos(theta(i+1))
21122         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21123         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21124         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21125         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21126         cosfac=dsqrt(cosfac2)
21127         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21128         sinfac=dsqrt(sinfac2)
21129         it=itype(i,2)
21130         if (it.eq.10) goto 1
21131
21132 !c
21133 !C  Compute the axes of tghe local cartesian coordinates system; store in
21134 !c   x_prime, y_prime and z_prime
21135 !c
21136         do j=1,3
21137           x_prime(j) = 0.00
21138           y_prime(j) = 0.00
21139           z_prime(j) = 0.00
21140         enddo
21141 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21142 !C     &   dc_norm(3,i+nres)
21143         do j = 1,3
21144           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21145           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21146         enddo
21147         do j = 1,3
21148           z_prime(j) = -uz(j,i-1)
21149 !           z_prime(j)=0.0
21150         enddo
21151
21152         xx=0.0d0
21153         yy=0.0d0
21154         zz=0.0d0
21155         do j = 1,3
21156           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21157           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21158           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21159         enddo
21160
21161         xxtab(i)=xx
21162         yytab(i)=yy
21163         zztab(i)=zz
21164          it=itype(i,2)
21165         do j = 1,9
21166           x(j) = sc_parmin_nucl(j,it)
21167         enddo
21168 #ifdef CHECK_COORD
21169 !Cc diagnostics - remove later
21170         xx1 = dcos(alph(2))
21171         yy1 = dsin(alph(2))*dcos(omeg(2))
21172         zz1 = -dsin(alph(2))*dsin(omeg(2))
21173         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21174          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21175          xx1,yy1,zz1
21176 !C,"  --- ", xx_w,yy_w,zz_w
21177 !c end diagnostics
21178 #endif
21179         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21180         esbloc = esbloc + sumene
21181         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21182 !        print *,"enecomp",sumene,sumene2
21183 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21184 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21185 #ifdef DEBUG
21186         write (2,*) "x",(x(k),k=1,9)
21187 !C
21188 !C This section to check the numerical derivatives of the energy of ith side
21189 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21190 !C #define DEBUG in the code to turn it on.
21191 !C
21192         write (2,*) "sumene               =",sumene
21193         aincr=1.0d-7
21194         xxsave=xx
21195         xx=xx+aincr
21196         write (2,*) xx,yy,zz
21197         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21198         de_dxx_num=(sumenep-sumene)/aincr
21199         xx=xxsave
21200         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21201         yysave=yy
21202         yy=yy+aincr
21203         write (2,*) xx,yy,zz
21204         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21205         de_dyy_num=(sumenep-sumene)/aincr
21206         yy=yysave
21207         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21208         zzsave=zz
21209         zz=zz+aincr
21210         write (2,*) xx,yy,zz
21211         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21212         de_dzz_num=(sumenep-sumene)/aincr
21213         zz=zzsave
21214         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21215         costsave=cost2tab(i+1)
21216         sintsave=sint2tab(i+1)
21217         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21218         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21219         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21220         de_dt_num=(sumenep-sumene)/aincr
21221         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21222         cost2tab(i+1)=costsave
21223         sint2tab(i+1)=sintsave
21224 !C End of diagnostics section.
21225 #endif
21226 !C
21227 !C Compute the gradient of esc
21228 !C
21229         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21230         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21231         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21232         de_dtt=0.0d0
21233 #ifdef DEBUG
21234         write (2,*) "x",(x(k),k=1,9)
21235         write (2,*) "xx",xx," yy",yy," zz",zz
21236         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21237           " de_zz   ",de_zz," de_tt   ",de_tt
21238         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21239           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21240 #endif
21241 !C
21242        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21243        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21244        cosfac2xx=cosfac2*xx
21245        sinfac2yy=sinfac2*yy
21246        do k = 1,3
21247          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21248            vbld_inv(i+1)
21249          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21250            vbld_inv(i)
21251          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21252          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21253 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21254 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21255 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21256 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21257          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21258          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21259          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21260          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21261          dZZ_Ci1(k)=0.0d0
21262          dZZ_Ci(k)=0.0d0
21263          do j=1,3
21264            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21265            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21266          enddo
21267
21268          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21269          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21270          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21271 !c
21272          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21273          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21274        enddo
21275
21276        do k=1,3
21277          dXX_Ctab(k,i)=dXX_Ci(k)
21278          dXX_C1tab(k,i)=dXX_Ci1(k)
21279          dYY_Ctab(k,i)=dYY_Ci(k)
21280          dYY_C1tab(k,i)=dYY_Ci1(k)
21281          dZZ_Ctab(k,i)=dZZ_Ci(k)
21282          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21283          dXX_XYZtab(k,i)=dXX_XYZ(k)
21284          dYY_XYZtab(k,i)=dYY_XYZ(k)
21285          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21286        enddo
21287        do k = 1,3
21288 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21289 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21290 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21291 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21292 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21293 !c     &    dt_dci(k)
21294 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21295 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21296          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21297          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21298          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21299          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21300          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21301          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21302 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21303        enddo
21304 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21305 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21306
21307 !C to check gradient call subroutine check_grad
21308
21309     1 continue
21310       enddo
21311       return
21312       end subroutine esb
21313 !=-------------------------------------------------------
21314       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21315 !      implicit none
21316       real(kind=8),dimension(9):: x(9)
21317        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21318       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21319       integer i
21320 !c      write (2,*) "enesc"
21321 !c      write (2,*) "x",(x(i),i=1,9)
21322 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21323       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21324         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21325         + x(9)*yy*zz
21326       enesc_nucl=sumene
21327       return
21328       end function enesc_nucl
21329 !-----------------------------------------------------------------------------
21330       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21331 #ifdef MPI
21332       include 'mpif.h'
21333       integer,parameter :: max_cont=2000
21334       integer,parameter:: max_dim=2*(8*3+6)
21335       integer, parameter :: msglen1=max_cont*max_dim
21336       integer,parameter :: msglen2=2*msglen1
21337       integer source,CorrelType,CorrelID,Error
21338       real(kind=8) :: buffer(max_cont,max_dim)
21339       integer status(MPI_STATUS_SIZE)
21340       integer :: ierror,nbytes
21341 #endif
21342       real(kind=8),dimension(3):: gx(3),gx1(3)
21343       real(kind=8) :: time00
21344       logical lprn,ldone
21345       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21346       real(kind=8) ecorr,ecorr3
21347       integer :: n_corr,n_corr1,mm,msglen
21348 !C Set lprn=.true. for debugging
21349       lprn=.false.
21350       n_corr=0
21351       n_corr1=0
21352 #ifdef MPI
21353       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21354
21355       if (nfgtasks.le.1) goto 30
21356       if (lprn) then
21357         write (iout,'(a)') 'Contact function values:'
21358         do i=nnt,nct-1
21359           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21360          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21361          j=1,num_cont_hb(i))
21362         enddo
21363       endif
21364 !C Caution! Following code assumes that electrostatic interactions concerning
21365 !C a given atom are split among at most two processors!
21366       CorrelType=477
21367       CorrelID=fg_rank+1
21368       ldone=.false.
21369       do i=1,max_cont
21370         do j=1,max_dim
21371           buffer(i,j)=0.0D0
21372         enddo
21373       enddo
21374       mm=mod(fg_rank,2)
21375 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21376       if (mm) 20,20,10
21377    10 continue
21378 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21379       if (fg_rank.gt.0) then
21380 !C Send correlation contributions to the preceding processor
21381         msglen=msglen1
21382         nn=num_cont_hb(iatel_s_nucl)
21383         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21384 !c        write (*,*) 'The BUFFER array:'
21385 !c        do i=1,nn
21386 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21387 !c        enddo
21388         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21389           msglen=msglen2
21390           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21391 !C Clear the contacts of the atom passed to the neighboring processor
21392         nn=num_cont_hb(iatel_s_nucl+1)
21393 !c        do i=1,nn
21394 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21395 !c        enddo
21396             num_cont_hb(iatel_s_nucl)=0
21397         endif
21398 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21399 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21400 !cd   & ' msglen=',msglen
21401 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21402 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21403 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21404         time00=MPI_Wtime()
21405         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21406          CorrelType,FG_COMM,IERROR)
21407         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21408 !cd      write (iout,*) 'Processor ',fg_rank,
21409 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21410 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21411 !c        write (*,*) 'Processor ',fg_rank,
21412 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21413 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21414 !c        msglen=msglen1
21415       endif ! (fg_rank.gt.0)
21416       if (ldone) goto 30
21417       ldone=.true.
21418    20 continue
21419 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21420       if (fg_rank.lt.nfgtasks-1) then
21421 !C Receive correlation contributions from the next processor
21422         msglen=msglen1
21423         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21424 !cd      write (iout,*) 'Processor',fg_rank,
21425 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21426 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21427 !c        write (*,*) 'Processor',fg_rank,
21428 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21429 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21430         time00=MPI_Wtime()
21431         nbytes=-1
21432         do while (nbytes.le.0)
21433           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21434           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21435         enddo
21436 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21437         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21438          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21439         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21440 !c        write (*,*) 'Processor',fg_rank,
21441 !c     &' has received correlation contribution from processor',fg_rank+1,
21442 !c     & ' msglen=',msglen,' nbytes=',nbytes
21443 !c        write (*,*) 'The received BUFFER array:'
21444 !c        do i=1,max_cont
21445 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21446 !c        enddo
21447         if (msglen.eq.msglen1) then
21448           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21449         else if (msglen.eq.msglen2)  then
21450           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21451           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21452         else
21453           write (iout,*) &
21454       'ERROR!!!! message length changed while processing correlations.'
21455           write (*,*) &
21456       'ERROR!!!! message length changed while processing correlations.'
21457           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21458         endif ! msglen.eq.msglen1
21459       endif ! fg_rank.lt.nfgtasks-1
21460       if (ldone) goto 30
21461       ldone=.true.
21462       goto 10
21463    30 continue
21464 #endif
21465       if (lprn) then
21466         write (iout,'(a)') 'Contact function values:'
21467         do i=nnt_molec(2),nct_molec(2)-1
21468           write (iout,'(2i3,50(1x,i2,f5.2))') &
21469          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21470          j=1,num_cont_hb(i))
21471         enddo
21472       endif
21473       ecorr=0.0D0
21474       ecorr3=0.0d0
21475 !C Remove the loop below after debugging !!!
21476 !      do i=nnt_molec(2),nct_molec(2)
21477 !        do j=1,3
21478 !          gradcorr_nucl(j,i)=0.0D0
21479 !          gradxorr_nucl(j,i)=0.0D0
21480 !          gradcorr3_nucl(j,i)=0.0D0
21481 !          gradxorr3_nucl(j,i)=0.0D0
21482 !        enddo
21483 !      enddo
21484 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21485 !C Calculate the local-electrostatic correlation terms
21486       do i=iatsc_s_nucl,iatsc_e_nucl
21487         i1=i+1
21488         num_conti=num_cont_hb(i)
21489         num_conti1=num_cont_hb(i+1)
21490 !        print *,i,num_conti,num_conti1
21491         do jj=1,num_conti
21492           j=jcont_hb(jj,i)
21493           do kk=1,num_conti1
21494             j1=jcont_hb(kk,i1)
21495 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21496 !c     &         ' jj=',jj,' kk=',kk
21497             if (j1.eq.j+1 .or. j1.eq.j-1) then
21498 !C
21499 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21500 !C The system gains extra energy.
21501 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21502 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21503 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21504 !C
21505               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21506               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21507                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21508               n_corr=n_corr+1
21509             else if (j1.eq.j) then
21510 !C
21511 !C Contacts I-J and I-(J+1) occur simultaneously.
21512 !C The system loses extra energy.
21513 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21514 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21515 !C Need to implement full formulas 32 from Liwo et al., 1998.
21516 !C
21517 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21518 !c     &         ' jj=',jj,' kk=',kk
21519               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21520             endif
21521           enddo ! kk
21522           do kk=1,num_conti
21523             j1=jcont_hb(kk,i)
21524 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21525 !c     &         ' jj=',jj,' kk=',kk
21526             if (j1.eq.j+1) then
21527 !C Contacts I-J and (I+1)-J occur simultaneously.
21528 !C The system loses extra energy.
21529               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21530             endif ! j1==j+1
21531           enddo ! kk
21532         enddo ! jj
21533       enddo ! i
21534       return
21535       end subroutine multibody_hb_nucl
21536 !-----------------------------------------------------------
21537       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21538 !      implicit real*8 (a-h,o-z)
21539 !      include 'DIMENSIONS'
21540 !      include 'COMMON.IOUNITS'
21541 !      include 'COMMON.DERIV'
21542 !      include 'COMMON.INTERACT'
21543 !      include 'COMMON.CONTACTS'
21544       real(kind=8),dimension(3) :: gx,gx1
21545       logical :: lprn
21546 !el local variables
21547       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21548       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21549                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21550                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21551                    rlocshield
21552
21553       lprn=.false.
21554       eij=facont_hb(jj,i)
21555       ekl=facont_hb(kk,k)
21556       ees0pij=ees0p(jj,i)
21557       ees0pkl=ees0p(kk,k)
21558       ees0mij=ees0m(jj,i)
21559       ees0mkl=ees0m(kk,k)
21560       ekont=eij*ekl
21561       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21562 !      print *,"ehbcorr_nucl",ekont,ees
21563 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21564 !C Following 4 lines for diagnostics.
21565 !cd    ees0pkl=0.0D0
21566 !cd    ees0pij=1.0D0
21567 !cd    ees0mkl=0.0D0
21568 !cd    ees0mij=1.0D0
21569 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21570 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21571 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21572 !C Calculate the multi-body contribution to energy.
21573 !      ecorr_nucl=ecorr_nucl+ekont*ees
21574 !C Calculate multi-body contributions to the gradient.
21575       coeffpees0pij=coeffp*ees0pij
21576       coeffmees0mij=coeffm*ees0mij
21577       coeffpees0pkl=coeffp*ees0pkl
21578       coeffmees0mkl=coeffm*ees0mkl
21579       do ll=1,3
21580         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21581        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21582        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21583         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21584         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21585         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21586         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21587         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21588         coeffmees0mij*gacontm_hb1(ll,kk,k))
21589         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21590         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21591         coeffmees0mij*gacontm_hb2(ll,kk,k))
21592         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21593           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21594           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21595         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21596         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21597         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21598           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21599           coeffmees0mij*gacontm_hb3(ll,kk,k))
21600         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21601         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21602         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21603         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21604         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21605         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21606       enddo
21607       ehbcorr_nucl=ekont*ees
21608       return
21609       end function ehbcorr_nucl
21610 !-------------------------------------------------------------------------
21611
21612      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21613 !      implicit real*8 (a-h,o-z)
21614 !      include 'DIMENSIONS'
21615 !      include 'COMMON.IOUNITS'
21616 !      include 'COMMON.DERIV'
21617 !      include 'COMMON.INTERACT'
21618 !      include 'COMMON.CONTACTS'
21619       real(kind=8),dimension(3) :: gx,gx1
21620       logical :: lprn
21621 !el local variables
21622       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21623       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21624                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21625                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21626                    rlocshield
21627
21628       lprn=.false.
21629       eij=facont_hb(jj,i)
21630       ekl=facont_hb(kk,k)
21631       ees0pij=ees0p(jj,i)
21632       ees0pkl=ees0p(kk,k)
21633       ees0mij=ees0m(jj,i)
21634       ees0mkl=ees0m(kk,k)
21635       ekont=eij*ekl
21636       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21637 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21638 !C Following 4 lines for diagnostics.
21639 !cd    ees0pkl=0.0D0
21640 !cd    ees0pij=1.0D0
21641 !cd    ees0mkl=0.0D0
21642 !cd    ees0mij=1.0D0
21643 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21644 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21645 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21646 !C Calculate the multi-body contribution to energy.
21647 !      ecorr=ecorr+ekont*ees
21648 !C Calculate multi-body contributions to the gradient.
21649       coeffpees0pij=coeffp*ees0pij
21650       coeffmees0mij=coeffm*ees0mij
21651       coeffpees0pkl=coeffp*ees0pkl
21652       coeffmees0mkl=coeffm*ees0mkl
21653       do ll=1,3
21654         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21655        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21656        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21657         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21658         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21659         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21660         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21661         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21662         coeffmees0mij*gacontm_hb1(ll,kk,k))
21663         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21664         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21665         coeffmees0mij*gacontm_hb2(ll,kk,k))
21666         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21667           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21668           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21669         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21670         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21671         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21672           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21673           coeffmees0mij*gacontm_hb3(ll,kk,k))
21674         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21675         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21676         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21677         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21678         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21679         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21680       enddo
21681       ehbcorr3_nucl=ekont*ees
21682       return
21683       end function ehbcorr3_nucl
21684 #ifdef MPI
21685       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21686       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21687       real(kind=8):: buffer(dimen1,dimen2)
21688       num_kont=num_cont_hb(atom)
21689       do i=1,num_kont
21690         do k=1,8
21691           do j=1,3
21692             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21693           enddo ! j
21694         enddo ! k
21695         buffer(i,indx+25)=facont_hb(i,atom)
21696         buffer(i,indx+26)=ees0p(i,atom)
21697         buffer(i,indx+27)=ees0m(i,atom)
21698         buffer(i,indx+28)=d_cont(i,atom)
21699         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21700       enddo ! i
21701       buffer(1,indx+30)=dfloat(num_kont)
21702       return
21703       end subroutine pack_buffer
21704 !c------------------------------------------------------------------------------
21705       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21706       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21707       real(kind=8):: buffer(dimen1,dimen2)
21708 !      double precision zapas
21709 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21710 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21711 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21712 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21713       num_kont=buffer(1,indx+30)
21714       num_kont_old=num_cont_hb(atom)
21715       num_cont_hb(atom)=num_kont+num_kont_old
21716       do i=1,num_kont
21717         ii=i+num_kont_old
21718         do k=1,8
21719           do j=1,3
21720             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21721           enddo ! j
21722         enddo ! k
21723         facont_hb(ii,atom)=buffer(i,indx+25)
21724         ees0p(ii,atom)=buffer(i,indx+26)
21725         ees0m(ii,atom)=buffer(i,indx+27)
21726         d_cont(i,atom)=buffer(i,indx+28)
21727         jcont_hb(ii,atom)=buffer(i,indx+29)
21728       enddo ! i
21729       return
21730       end subroutine unpack_buffer
21731 !c------------------------------------------------------------------------------
21732 #endif
21733       subroutine ecatcat(ecationcation)
21734         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21735         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21736         r7,r4,ecationcation,k0,rcal
21737         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21738         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21739         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21740         gg,r
21741
21742         ecationcation=0.0d0
21743         if (nres_molec(5).eq.0) return
21744         rcat0=3.472
21745         epscalc=0.05
21746         r06 = rcat0**6
21747         r012 = r06**2
21748         k0 = 332.0*(2.0*2.0)/80.0
21749         itmp=0
21750         do i=1,4
21751         itmp=itmp+nres_molec(i)
21752         enddo
21753         do i=itmp+1,itmp+nres_molec(5)-1
21754
21755         xi=c(1,i)
21756         yi=c(2,i)
21757         zi=c(3,i)
21758           xi=mod(xi,boxxsize)
21759           if (xi.lt.0) xi=xi+boxxsize
21760           yi=mod(yi,boxysize)
21761           if (yi.lt.0) yi=yi+boxysize
21762           zi=mod(zi,boxzsize)
21763           if (zi.lt.0) zi=zi+boxzsize
21764
21765           do j=i+1,itmp+nres_molec(5)
21766 !           print *,i,j,'catcat'
21767            xj=c(1,j)
21768            yj=c(2,j)
21769            zj=c(3,j)
21770           xj=dmod(xj,boxxsize)
21771           if (xj.lt.0) xj=xj+boxxsize
21772           yj=dmod(yj,boxysize)
21773           if (yj.lt.0) yj=yj+boxysize
21774           zj=dmod(zj,boxzsize)
21775           if (zj.lt.0) zj=zj+boxzsize
21776       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21777       xj_safe=xj
21778       yj_safe=yj
21779       zj_safe=zj
21780       subchap=0
21781       do xshift=-1,1
21782       do yshift=-1,1
21783       do zshift=-1,1
21784           xj=xj_safe+xshift*boxxsize
21785           yj=yj_safe+yshift*boxysize
21786           zj=zj_safe+zshift*boxzsize
21787           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21788           if(dist_temp.lt.dist_init) then
21789             dist_init=dist_temp
21790             xj_temp=xj
21791             yj_temp=yj
21792             zj_temp=zj
21793             subchap=1
21794           endif
21795        enddo
21796        enddo
21797        enddo
21798        if (subchap.eq.1) then
21799           xj=xj_temp-xi
21800           yj=yj_temp-yi
21801           zj=zj_temp-zi
21802        else
21803           xj=xj_safe-xi
21804           yj=yj_safe-yi
21805           zj=zj_safe-zi
21806        endif
21807        rcal =xj**2+yj**2+zj**2
21808         ract=sqrt(rcal)
21809 !        rcat0=3.472
21810 !        epscalc=0.05
21811 !        r06 = rcat0**6
21812 !        r012 = r06**2
21813 !        k0 = 332*(2*2)/80
21814         Evan1cat=epscalc*(r012/rcal**6)
21815         Evan2cat=epscalc*2*(r06/rcal**3)
21816         Eeleccat=k0/ract
21817         r7 = rcal**7
21818         r4 = rcal**4
21819         r(1)=xj
21820         r(2)=yj
21821         r(3)=zj
21822         do k=1,3
21823           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21824           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21825           dEeleccat(k)=-k0*r(k)/ract**3
21826         enddo
21827         do k=1,3
21828           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21829           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
21830           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
21831         enddo
21832
21833         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
21834        enddo
21835        enddo
21836        return
21837        end subroutine ecatcat
21838 !---------------------------------------------------------------------------
21839        subroutine ecat_prot(ecation_prot)
21840        integer i,j,k,subchap,itmp,inum
21841         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21842         r7,r4,ecationcation
21843         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21844         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
21845         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
21846         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
21847         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
21848         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
21849         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
21850         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
21851         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
21852         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
21853         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
21854         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21855         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
21856         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
21857         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
21858         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
21859         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
21860         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
21861         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
21862         dEvan1Cat
21863         real(kind=8),dimension(6) :: vcatprm
21864         ecation_prot=0.0d0
21865 ! first lets calculate interaction with peptide groups
21866         if (nres_molec(5).eq.0) return
21867          wconst=78
21868         wdip =1.092777950857032D2
21869         wdip=wdip/wconst
21870         wmodquad=-2.174122713004870D4
21871         wmodquad=wmodquad/wconst
21872         wquad1 = 3.901232068562804D1
21873         wquad1=wquad1/wconst
21874         wquad2 = 3
21875         wquad2=wquad2/wconst
21876         wvan1 = 0.1
21877         wvan2 = 6
21878         itmp=0
21879         do i=1,4
21880         itmp=itmp+nres_molec(i)
21881         enddo
21882 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
21883         do i=ibond_start,ibond_end
21884 !         cycle
21885          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
21886         xi=0.5d0*(c(1,i)+c(1,i+1))
21887         yi=0.5d0*(c(2,i)+c(2,i+1))
21888         zi=0.5d0*(c(3,i)+c(3,i+1))
21889           xi=mod(xi,boxxsize)
21890           if (xi.lt.0) xi=xi+boxxsize
21891           yi=mod(yi,boxysize)
21892           if (yi.lt.0) yi=yi+boxysize
21893           zi=mod(zi,boxzsize)
21894           if (zi.lt.0) zi=zi+boxzsize
21895
21896          do j=itmp+1,itmp+nres_molec(5)
21897            xj=c(1,j)
21898            yj=c(2,j)
21899            zj=c(3,j)
21900           xj=dmod(xj,boxxsize)
21901           if (xj.lt.0) xj=xj+boxxsize
21902           yj=dmod(yj,boxysize)
21903           if (yj.lt.0) yj=yj+boxysize
21904           zj=dmod(zj,boxzsize)
21905           if (zj.lt.0) zj=zj+boxzsize
21906       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21907       xj_safe=xj
21908       yj_safe=yj
21909       zj_safe=zj
21910       subchap=0
21911       do xshift=-1,1
21912       do yshift=-1,1
21913       do zshift=-1,1
21914           xj=xj_safe+xshift*boxxsize
21915           yj=yj_safe+yshift*boxysize
21916           zj=zj_safe+zshift*boxzsize
21917           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21918           if(dist_temp.lt.dist_init) then
21919             dist_init=dist_temp
21920             xj_temp=xj
21921             yj_temp=yj
21922             zj_temp=zj
21923             subchap=1
21924           endif
21925        enddo
21926        enddo
21927        enddo
21928        if (subchap.eq.1) then
21929           xj=xj_temp-xi
21930           yj=yj_temp-yi
21931           zj=zj_temp-zi
21932        else
21933           xj=xj_safe-xi
21934           yj=yj_safe-yi
21935           zj=zj_safe-zi
21936        endif
21937 !       enddo
21938 !       enddo
21939        rcpm = sqrt(xj**2+yj**2+zj**2)
21940        drcp_norm(1)=xj/rcpm
21941        drcp_norm(2)=yj/rcpm
21942        drcp_norm(3)=zj/rcpm
21943        dcmag=0.0
21944        do k=1,3
21945        dcmag=dcmag+dc(k,i)**2
21946        enddo
21947        dcmag=dsqrt(dcmag)
21948        do k=1,3
21949          myd_norm(k)=dc(k,i)/dcmag
21950        enddo
21951         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
21952         drcp_norm(3)*myd_norm(3)
21953         rsecp = rcpm**2
21954         Ir = 1.0d0/rcpm
21955         Irsecp = 1.0d0/rsecp
21956         Irthrp = Irsecp/rcpm
21957         Irfourp = Irthrp/rcpm
21958         Irfiftp = Irfourp/rcpm
21959         Irsistp=Irfiftp/rcpm
21960         Irseven=Irsistp/rcpm
21961         Irtwelv=Irsistp*Irsistp
21962         Irthir=Irtwelv/rcpm
21963         sin2thet = (1-costhet*costhet)
21964         sinthet=sqrt(sin2thet)
21965         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
21966              *sin2thet
21967         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
21968              2*wvan2**6*Irsistp)
21969         ecation_prot = ecation_prot+E1+E2
21970         dE1dr = -2*costhet*wdip*Irthrp-&
21971          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
21972         dE2dr = 3*wquad1*wquad2*Irfourp-     &
21973           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
21974         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
21975         do k=1,3
21976           drdpep(k) = -drcp_norm(k)
21977           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
21978           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
21979           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
21980           dEddci(k) = dEdcos*dcosddci(k)
21981         enddo
21982         do k=1,3
21983         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
21984         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
21985         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
21986         enddo
21987        enddo ! j
21988        enddo ! i
21989 !------------------------------------------sidechains
21990 !        do i=1,nres_molec(1)
21991         do i=ibond_start,ibond_end
21992          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
21993 !         cycle
21994 !        print *,i,ecation_prot
21995         xi=(c(1,i+nres))
21996         yi=(c(2,i+nres))
21997         zi=(c(3,i+nres))
21998           xi=mod(xi,boxxsize)
21999           if (xi.lt.0) xi=xi+boxxsize
22000           yi=mod(yi,boxysize)
22001           if (yi.lt.0) yi=yi+boxysize
22002           zi=mod(zi,boxzsize)
22003           if (zi.lt.0) zi=zi+boxzsize
22004           do k=1,3
22005             cm1(k)=dc(k,i+nres)
22006           enddo
22007            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22008          do j=itmp+1,itmp+nres_molec(5)
22009            xj=c(1,j)
22010            yj=c(2,j)
22011            zj=c(3,j)
22012           xj=dmod(xj,boxxsize)
22013           if (xj.lt.0) xj=xj+boxxsize
22014           yj=dmod(yj,boxysize)
22015           if (yj.lt.0) yj=yj+boxysize
22016           zj=dmod(zj,boxzsize)
22017           if (zj.lt.0) zj=zj+boxzsize
22018       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22019       xj_safe=xj
22020       yj_safe=yj
22021       zj_safe=zj
22022       subchap=0
22023       do xshift=-1,1
22024       do yshift=-1,1
22025       do zshift=-1,1
22026           xj=xj_safe+xshift*boxxsize
22027           yj=yj_safe+yshift*boxysize
22028           zj=zj_safe+zshift*boxzsize
22029           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22030           if(dist_temp.lt.dist_init) then
22031             dist_init=dist_temp
22032             xj_temp=xj
22033             yj_temp=yj
22034             zj_temp=zj
22035             subchap=1
22036           endif
22037        enddo
22038        enddo
22039        enddo
22040        if (subchap.eq.1) then
22041           xj=xj_temp-xi
22042           yj=yj_temp-yi
22043           zj=zj_temp-zi
22044        else
22045           xj=xj_safe-xi
22046           yj=yj_safe-yi
22047           zj=zj_safe-zi
22048        endif
22049 !       enddo
22050 !       enddo
22051          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22052             if(itype(i,1).eq.16) then
22053             inum=1
22054             else
22055             inum=2
22056             endif
22057             do k=1,6
22058             vcatprm(k)=catprm(k,inum)
22059             enddo
22060             dASGL=catprm(7,inum)
22061              do k=1,3
22062                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22063                 valpha(k)=c(k,i)
22064                 vcat(k)=c(k,j)
22065               enddo
22066                       do k=1,3
22067           dx(k) = vcat(k)-vcm(k)
22068         enddo
22069         do k=1,3
22070           v1(k)=(vcm(k)-valpha(k))
22071           v2(k)=(vcat(k)-valpha(k))
22072         enddo
22073         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22074         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22075         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22076
22077 !  The weights of the energy function calculated from
22078 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22079         wh2o=78
22080         wc = vcatprm(1)
22081         wc=wc/wh2o
22082         wdip =vcatprm(2)
22083         wdip=wdip/wh2o
22084         wquad1 =vcatprm(3)
22085         wquad1=wquad1/wh2o
22086         wquad2 = vcatprm(4)
22087         wquad2=wquad2/wh2o
22088         wquad2p = 1-wquad2
22089         wvan1 = vcatprm(5)
22090         wvan2 =vcatprm(6)
22091         opt = dx(1)**2+dx(2)**2
22092         rsecp = opt+dx(3)**2
22093         rs = sqrt(rsecp)
22094         rthrp = rsecp*rs
22095         rfourp = rthrp*rs
22096         rsixp = rfourp*rsecp
22097         reight=rsixp*rsecp
22098         Ir = 1.0d0/rs
22099         Irsecp = 1/rsecp
22100         Irthrp = Irsecp/rs
22101         Irfourp = Irthrp/rs
22102         Irsixp = 1/rsixp
22103         Ireight=1/reight
22104         Irtw=Irsixp*Irsixp
22105         Irthir=Irtw/rs
22106         Irfourt=Irthir/rs
22107         opt1 = (4*rs*dx(3)*wdip)
22108         opt2 = 6*rsecp*wquad1*opt
22109         opt3 = wquad1*wquad2p*Irsixp
22110         opt4 = (wvan1*wvan2**12)
22111         opt5 = opt4*12*Irfourt
22112         opt6 = 2*wvan1*wvan2**6
22113         opt7 = 6*opt6*Ireight
22114         opt8 = wdip/v1m
22115         opt10 = wdip/v2m
22116         opt11 = (rsecp*v2m)**2
22117         opt12 = (rsecp*v1m)**2
22118         opt14 = (v1m*v2m*rsecp)**2
22119         opt15 = -wquad1/v2m**2
22120         opt16 = (rthrp*(v1m*v2m)**2)**2
22121         opt17 = (v1m**2*rthrp)**2
22122         opt18 = -wquad1/rthrp
22123         opt19 = (v1m**2*v2m**2)**2
22124         Ec = wc*Ir
22125         do k=1,3
22126           dEcCat(k) = -(dx(k)*wc)*Irthrp
22127           dEcCm(k)=(dx(k)*wc)*Irthrp
22128           dEcCalp(k)=0.0d0
22129         enddo
22130         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22131         do k=1,3
22132           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22133                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22134           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22135                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22136           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22137                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22138                       *v1dpv2)/opt14
22139         enddo
22140         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22141         do k=1,3
22142           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22143                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22144                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22145           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22146                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22147                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22148           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22149                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22150                         v1dpv2**2)/opt19
22151         enddo
22152         Equad2=wquad1*wquad2p*Irthrp
22153         do k=1,3
22154           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22155           dEquad2Cm(k)=3*dx(k)*rs*opt3
22156           dEquad2Calp(k)=0.0d0
22157         enddo
22158         Evan1=opt4*Irtw
22159         do k=1,3
22160           dEvan1Cat(k)=-dx(k)*opt5
22161           dEvan1Cm(k)=dx(k)*opt5
22162           dEvan1Calp(k)=0.0d0
22163         enddo
22164         Evan2=-opt6*Irsixp
22165         do k=1,3
22166           dEvan2Cat(k)=dx(k)*opt7
22167           dEvan2Cm(k)=-dx(k)*opt7
22168           dEvan2Calp(k)=0.0d0
22169         enddo
22170         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22171 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22172
22173         do k=1,3
22174           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22175                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22176 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22177           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22178                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22179           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22180                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22181         enddo
22182             dscmag = 0.0d0
22183             do k=1,3
22184               dscvec(k) = dc(k,i+nres)
22185               dscmag = dscmag+dscvec(k)*dscvec(k)
22186             enddo
22187             dscmag3 = dscmag
22188             dscmag = sqrt(dscmag)
22189             dscmag3 = dscmag3*dscmag
22190             constA = 1.0d0+dASGL/dscmag
22191             constB = 0.0d0
22192             do k=1,3
22193               constB = constB+dscvec(k)*dEtotalCm(k)
22194             enddo
22195             constB = constB*dASGL/dscmag3
22196             do k=1,3
22197               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22198               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22199                constA*dEtotalCm(k)-constB*dscvec(k)
22200 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22201               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22202               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22203              enddo
22204         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22205            if(itype(i,1).eq.14) then
22206             inum=3
22207             else
22208             inum=4
22209             endif
22210             do k=1,6
22211             vcatprm(k)=catprm(k,inum)
22212             enddo
22213             dASGL=catprm(7,inum)
22214              do k=1,3
22215                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22216                 valpha(k)=c(k,i)
22217                 vcat(k)=c(k,j)
22218               enddo
22219
22220         do k=1,3
22221           dx(k) = vcat(k)-vcm(k)
22222         enddo
22223         do k=1,3
22224           v1(k)=(vcm(k)-valpha(k))
22225           v2(k)=(vcat(k)-valpha(k))
22226         enddo
22227         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22228         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22229         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22230 !  The weights of the energy function calculated from
22231 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22232         wh2o=78
22233         wdip =vcatprm(2)
22234         wdip=wdip/wh2o
22235         wquad1 =vcatprm(3)
22236         wquad1=wquad1/wh2o
22237         wquad2 = vcatprm(4)
22238         wquad2=wquad2/wh2o
22239         wquad2p = 1-wquad2
22240         wvan1 = vcatprm(5)
22241         wvan2 =vcatprm(6)
22242         opt = dx(1)**2+dx(2)**2
22243         rsecp = opt+dx(3)**2
22244         rs = sqrt(rsecp)
22245         rthrp = rsecp*rs
22246         rfourp = rthrp*rs
22247         rsixp = rfourp*rsecp
22248         reight=rsixp*rsecp
22249         Ir = 1.0d0/rs
22250         Irsecp = 1/rsecp
22251         Irthrp = Irsecp/rs
22252         Irfourp = Irthrp/rs
22253         Irsixp = 1/rsixp
22254         Ireight=1/reight
22255         Irtw=Irsixp*Irsixp
22256         Irthir=Irtw/rs
22257         Irfourt=Irthir/rs
22258         opt1 = (4*rs*dx(3)*wdip)
22259         opt2 = 6*rsecp*wquad1*opt
22260         opt3 = wquad1*wquad2p*Irsixp
22261         opt4 = (wvan1*wvan2**12)
22262         opt5 = opt4*12*Irfourt
22263         opt6 = 2*wvan1*wvan2**6
22264         opt7 = 6*opt6*Ireight
22265         opt8 = wdip/v1m
22266         opt10 = wdip/v2m
22267         opt11 = (rsecp*v2m)**2
22268         opt12 = (rsecp*v1m)**2
22269         opt14 = (v1m*v2m*rsecp)**2
22270         opt15 = -wquad1/v2m**2
22271         opt16 = (rthrp*(v1m*v2m)**2)**2
22272         opt17 = (v1m**2*rthrp)**2
22273         opt18 = -wquad1/rthrp
22274         opt19 = (v1m**2*v2m**2)**2
22275         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22276         do k=1,3
22277           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22278                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22279          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22280                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22281           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22282                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22283                       *v1dpv2)/opt14
22284         enddo
22285         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22286         do k=1,3
22287           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22288                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22289                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22290           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22291                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22292                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22293           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22294                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22295                         v1dpv2**2)/opt19
22296         enddo
22297         Equad2=wquad1*wquad2p*Irthrp
22298         do k=1,3
22299           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22300           dEquad2Cm(k)=3*dx(k)*rs*opt3
22301           dEquad2Calp(k)=0.0d0
22302         enddo
22303         Evan1=opt4*Irtw
22304         do k=1,3
22305           dEvan1Cat(k)=-dx(k)*opt5
22306           dEvan1Cm(k)=dx(k)*opt5
22307           dEvan1Calp(k)=0.0d0
22308         enddo
22309         Evan2=-opt6*Irsixp
22310         do k=1,3
22311           dEvan2Cat(k)=dx(k)*opt7
22312           dEvan2Cm(k)=-dx(k)*opt7
22313           dEvan2Calp(k)=0.0d0
22314         enddo
22315          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22316         do k=1,3
22317           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22318                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22319           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22320                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22321           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22322                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22323         enddo
22324             dscmag = 0.0d0
22325             do k=1,3
22326               dscvec(k) = c(k,i+nres)-c(k,i)
22327               dscmag = dscmag+dscvec(k)*dscvec(k)
22328             enddo
22329             dscmag3 = dscmag
22330             dscmag = sqrt(dscmag)
22331             dscmag3 = dscmag3*dscmag
22332             constA = 1+dASGL/dscmag
22333             constB = 0.0d0
22334             do k=1,3
22335               constB = constB+dscvec(k)*dEtotalCm(k)
22336             enddo
22337             constB = constB*dASGL/dscmag3
22338             do k=1,3
22339               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22340               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22341                constA*dEtotalCm(k)-constB*dscvec(k)
22342               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22343               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22344              enddo
22345            else
22346             rcal = 0.0d0
22347             do k=1,3
22348               r(k) = c(k,j)-c(k,i+nres)
22349               rcal = rcal+r(k)*r(k)
22350             enddo
22351             ract=sqrt(rcal)
22352             rocal=1.5
22353             epscalc=0.2
22354             r0p=0.5*(rocal+sig0(itype(i,1)))
22355             r06 = r0p**6
22356             r012 = r06*r06
22357             Evan1=epscalc*(r012/rcal**6)
22358             Evan2=epscalc*2*(r06/rcal**3)
22359             r4 = rcal**4
22360             r7 = rcal**7
22361             do k=1,3
22362               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22363               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22364             enddo
22365             do k=1,3
22366               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22367             enddo
22368                  ecation_prot = ecation_prot+ Evan1+Evan2
22369             do  k=1,3
22370                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22371                dEtotalCm(k)
22372               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22373               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22374              enddo
22375          endif ! 13-16 residues
22376        enddo !j
22377        enddo !i
22378        return
22379        end subroutine ecat_prot
22380
22381 !----------------------------------------------------------------------------
22382 !-----------------------------------------------------------------------------
22383 !-----------------------------------------------------------------------------
22384       subroutine eprot_sc_base(escbase)
22385       use calc_data
22386 !      implicit real*8 (a-h,o-z)
22387 !      include 'DIMENSIONS'
22388 !      include 'COMMON.GEO'
22389 !      include 'COMMON.VAR'
22390 !      include 'COMMON.LOCAL'
22391 !      include 'COMMON.CHAIN'
22392 !      include 'COMMON.DERIV'
22393 !      include 'COMMON.NAMES'
22394 !      include 'COMMON.INTERACT'
22395 !      include 'COMMON.IOUNITS'
22396 !      include 'COMMON.CALC'
22397 !      include 'COMMON.CONTROL'
22398 !      include 'COMMON.SBRIDGE'
22399       logical :: lprn
22400 !el local variables
22401       integer :: iint,itypi,itypi1,itypj,subchap
22402       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22403       real(kind=8) :: evdw,sig0ij
22404       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22405                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22406                     sslipi,sslipj,faclip
22407       integer :: ii
22408       real(kind=8) :: fracinbuf
22409        real (kind=8) :: escbase
22410        real (kind=8),dimension(4):: ener
22411        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22412        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22413         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22414         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22415         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22416         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22417         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22418         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22419        real(kind=8),dimension(3,2)::chead,erhead_tail
22420        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22421        integer troll
22422        eps_out=80.0d0
22423        escbase=0.0d0
22424 !       do i=1,nres_molec(1)
22425         do i=ibond_start,ibond_end
22426         if (itype(i,1).eq.ntyp1_molec(1)) cycle
22427         itypi  = itype(i,1)
22428         dxi    = dc_norm(1,nres+i)
22429         dyi    = dc_norm(2,nres+i)
22430         dzi    = dc_norm(3,nres+i)
22431         dsci_inv = vbld_inv(i+nres)
22432         xi=c(1,nres+i)
22433         yi=c(2,nres+i)
22434         zi=c(3,nres+i)
22435         xi=mod(xi,boxxsize)
22436          if (xi.lt.0) xi=xi+boxxsize
22437         yi=mod(yi,boxysize)
22438          if (yi.lt.0) yi=yi+boxysize
22439         zi=mod(zi,boxzsize)
22440          if (zi.lt.0) zi=zi+boxzsize
22441          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22442            itypj= itype(j,2)
22443            if (itype(j,2).eq.ntyp1_molec(2))cycle
22444            xj=c(1,j+nres)
22445            yj=c(2,j+nres)
22446            zj=c(3,j+nres)
22447            xj=dmod(xj,boxxsize)
22448            if (xj.lt.0) xj=xj+boxxsize
22449            yj=dmod(yj,boxysize)
22450            if (yj.lt.0) yj=yj+boxysize
22451            zj=dmod(zj,boxzsize)
22452            if (zj.lt.0) zj=zj+boxzsize
22453           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22454           xj_safe=xj
22455           yj_safe=yj
22456           zj_safe=zj
22457           subchap=0
22458
22459           do xshift=-1,1
22460           do yshift=-1,1
22461           do zshift=-1,1
22462           xj=xj_safe+xshift*boxxsize
22463           yj=yj_safe+yshift*boxysize
22464           zj=zj_safe+zshift*boxzsize
22465           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22466           if(dist_temp.lt.dist_init) then
22467             dist_init=dist_temp
22468             xj_temp=xj
22469             yj_temp=yj
22470             zj_temp=zj
22471             subchap=1
22472           endif
22473           enddo
22474           enddo
22475           enddo
22476           if (subchap.eq.1) then
22477           xj=xj_temp-xi
22478           yj=yj_temp-yi
22479           zj=zj_temp-zi
22480           else
22481           xj=xj_safe-xi
22482           yj=yj_safe-yi
22483           zj=zj_safe-zi
22484           endif
22485           dxj = dc_norm( 1, nres+j )
22486           dyj = dc_norm( 2, nres+j )
22487           dzj = dc_norm( 3, nres+j )
22488 !          print *,i,j,itypi,itypj
22489           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
22490           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
22491 !          d1i=0.0d0
22492 !          d1j=0.0d0
22493 !          BetaT = 1.0d0 / (298.0d0 * Rb)
22494 ! Gay-berne var's
22495           sig0ij = sigma_scbase( itypi,itypj )
22496           chi1   = chi_scbase( itypi, itypj,1 )
22497           chi2   = chi_scbase( itypi, itypj,2 )
22498 !          chi1=0.0d0
22499 !          chi2=0.0d0
22500           chi12  = chi1 * chi2
22501           chip1  = chipp_scbase( itypi, itypj,1 )
22502           chip2  = chipp_scbase( itypi, itypj,2 )
22503 !          chip1=0.0d0
22504 !          chip2=0.0d0
22505           chip12 = chip1 * chip2
22506 ! not used by momo potential, but needed by sc_angular which is shared
22507 ! by all energy_potential subroutines
22508           alf1   = 0.0d0
22509           alf2   = 0.0d0
22510           alf12  = 0.0d0
22511           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
22512 !       a12sq = a12sq * a12sq
22513 ! charge of amino acid itypi is...
22514           chis1 = chis_scbase(itypi,itypj,1)
22515           chis2 = chis_scbase(itypi,itypj,2)
22516           chis12 = chis1 * chis2
22517           sig1 = sigmap1_scbase(itypi,itypj)
22518           sig2 = sigmap2_scbase(itypi,itypj)
22519 !       write (*,*) "sig1 = ", sig1
22520 !       write (*,*) "sig2 = ", sig2
22521 ! alpha factors from Fcav/Gcav
22522           b1 = alphasur_scbase(1,itypi,itypj)
22523 !          b1=0.0d0
22524           b2 = alphasur_scbase(2,itypi,itypj)
22525           b3 = alphasur_scbase(3,itypi,itypj)
22526           b4 = alphasur_scbase(4,itypi,itypj)
22527 ! used to determine whether we want to do quadrupole calculations
22528 ! used by Fgb
22529        eps_in = epsintab_scbase(itypi,itypj)
22530        if (eps_in.eq.0.0) eps_in=1.0
22531        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22532 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
22533 !-------------------------------------------------------------------
22534 ! tail location and distance calculations
22535        DO k = 1,3
22536 ! location of polar head is computed by taking hydrophobic centre
22537 ! and moving by a d1 * dc_norm vector
22538 ! see unres publications for very informative images
22539         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
22540         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
22541 ! distance
22542 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22543 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22544         Rhead_distance(k) = chead(k,2) - chead(k,1)
22545        END DO
22546 ! pitagoras (root of sum of squares)
22547        Rhead = dsqrt( &
22548           (Rhead_distance(1)*Rhead_distance(1)) &
22549         + (Rhead_distance(2)*Rhead_distance(2)) &
22550         + (Rhead_distance(3)*Rhead_distance(3)))
22551 !-------------------------------------------------------------------
22552 ! zero everything that should be zero'ed
22553        evdwij = 0.0d0
22554        ECL = 0.0d0
22555        Elj = 0.0d0
22556        Equad = 0.0d0
22557        Epol = 0.0d0
22558        Fcav=0.0d0
22559        eheadtail = 0.0d0
22560        dGCLdOM1 = 0.0d0
22561        dGCLdOM2 = 0.0d0
22562        dGCLdOM12 = 0.0d0
22563        dPOLdOM1 = 0.0d0
22564        dPOLdOM2 = 0.0d0
22565           Fcav = 0.0d0
22566           dFdR = 0.0d0
22567           dCAVdOM1  = 0.0d0
22568           dCAVdOM2  = 0.0d0
22569           dCAVdOM12 = 0.0d0
22570           dscj_inv = vbld_inv(j+nres)
22571 !          print *,i,j,dscj_inv,dsci_inv
22572 ! rij holds 1/(distance of Calpha atoms)
22573           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22574           rij  = dsqrt(rrij)
22575 !----------------------------
22576           CALL sc_angular
22577 ! this should be in elgrad_init but om's are calculated by sc_angular
22578 ! which in turn is used by older potentials
22579 ! om = omega, sqom = om^2
22580           sqom1  = om1 * om1
22581           sqom2  = om2 * om2
22582           sqom12 = om12 * om12
22583
22584 ! now we calculate EGB - Gey-Berne
22585 ! It will be summed up in evdwij and saved in evdw
22586           sigsq     = 1.0D0  / sigsq
22587           sig       = sig0ij * dsqrt(sigsq)
22588 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22589           rij_shift = 1.0/rij - sig + sig0ij
22590           IF (rij_shift.le.0.0D0) THEN
22591            evdw = 1.0D20
22592            RETURN
22593           END IF
22594           sigder = -sig * sigsq
22595           rij_shift = 1.0D0 / rij_shift
22596           fac       = rij_shift**expon
22597           c1        = fac  * fac * aa_scbase(itypi,itypj)
22598 !          c1        = 0.0d0
22599           c2        = fac  * bb_scbase(itypi,itypj)
22600 !          c2        = 0.0d0
22601           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22602           eps2der   = eps3rt * evdwij
22603           eps3der   = eps2rt * evdwij
22604 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22605           evdwij    = eps2rt * eps3rt * evdwij
22606           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22607           fac    = -expon * (c1 + evdwij) * rij_shift
22608           sigder = fac * sigder
22609 !          fac    = rij * fac
22610 ! Calculate distance derivative
22611           gg(1) =  fac
22612           gg(2) =  fac
22613           gg(3) =  fac
22614 !          if (b2.gt.0.0) then
22615           fac = chis1 * sqom1 + chis2 * sqom2 &
22616           - 2.0d0 * chis12 * om1 * om2 * om12
22617 ! we will use pom later in Gcav, so dont mess with it!
22618           pom = 1.0d0 - chis1 * chis2 * sqom12
22619           Lambf = (1.0d0 - (fac / pom))
22620           Lambf = dsqrt(Lambf)
22621           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22622 !       write (*,*) "sparrow = ", sparrow
22623           Chif = 1.0d0/rij * sparrow
22624           ChiLambf = Chif * Lambf
22625           eagle = dsqrt(ChiLambf)
22626           bat = ChiLambf ** 11.0d0
22627           top = b1 * ( eagle + b2 * ChiLambf - b3 )
22628           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
22629           botsq = bot * bot
22630           Fcav = top / bot
22631 !          print *,i,j,Fcav
22632           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
22633           dbot = 12.0d0 * b4 * bat * Lambf
22634           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22635 !       dFdR = 0.0d0
22636 !      write (*,*) "dFcav/dR = ", dFdR
22637           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
22638           dbot = 12.0d0 * b4 * bat * Chif
22639           eagle = Lambf * pom
22640           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22641           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22642           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22643               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22644
22645           dFdL = ((dtop * bot - top * dbot) / botsq)
22646 !       dFdL = 0.0d0
22647           dCAVdOM1  = dFdL * ( dFdOM1 )
22648           dCAVdOM2  = dFdL * ( dFdOM2 )
22649           dCAVdOM12 = dFdL * ( dFdOM12 )
22650
22651           ertail(1) = xj*rij
22652           ertail(2) = yj*rij
22653           ertail(3) = zj*rij
22654 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
22655 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
22656 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
22657 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
22658 !           print *,"EOMY",eom1,eom2,eom12
22659 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22660 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
22661 ! here dtail=0.0
22662 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
22663 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22664        DO k = 1, 3
22665 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22666 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22667         pom = ertail(k)
22668 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22669         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22670                   - (( dFdR + gg(k) ) * pom)
22671 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22672 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22673 !     &             - ( dFdR * pom )
22674         pom = ertail(k)
22675 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22676         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22677                   + (( dFdR + gg(k) ) * pom)
22678 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22679 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22680 !c!     &             + ( dFdR * pom )
22681
22682         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22683                   - (( dFdR + gg(k) ) * ertail(k))
22684 !c!     &             - ( dFdR * ertail(k))
22685
22686         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22687                   + (( dFdR + gg(k) ) * ertail(k))
22688 !c!     &             + ( dFdR * ertail(k))
22689
22690         gg(k) = 0.0d0
22691 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22692 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22693       END DO
22694
22695 !          else
22696
22697 !          endif
22698 !Now dipole-dipole
22699          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
22700        w1 = wdipdip_scbase(1,itypi,itypj)
22701        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
22702        w3 = wdipdip_scbase(2,itypi,itypj)
22703 !c!-------------------------------------------------------------------
22704 !c! ECL
22705        fac = (om12 - 3.0d0 * om1 * om2)
22706        c1 = (w1 / (Rhead**3.0d0)) * fac
22707        c2 = (w2 / Rhead ** 6.0d0)  &
22708          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22709        c3= (w3/ Rhead ** 6.0d0)  &
22710          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22711        ECL = c1 - c2 + c3
22712 !c!       write (*,*) "w1 = ", w1
22713 !c!       write (*,*) "w2 = ", w2
22714 !c!       write (*,*) "om1 = ", om1
22715 !c!       write (*,*) "om2 = ", om2
22716 !c!       write (*,*) "om12 = ", om12
22717 !c!       write (*,*) "fac = ", fac
22718 !c!       write (*,*) "c1 = ", c1
22719 !c!       write (*,*) "c2 = ", c2
22720 !c!       write (*,*) "Ecl = ", Ecl
22721 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
22722 !c!       write (*,*) "c2_2 = ",
22723 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22724 !c!-------------------------------------------------------------------
22725 !c! dervative of ECL is GCL...
22726 !c! dECL/dr
22727        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
22728        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
22729          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
22730        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
22731          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22732        dGCLdR = c1 - c2 + c3
22733 !c! dECL/dom1
22734        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
22735        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22736          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
22737        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
22738        dGCLdOM1 = c1 - c2 + c3
22739 !c! dECL/dom2
22740        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
22741        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22742          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
22743        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
22744        dGCLdOM2 = c1 - c2 + c3
22745 !c! dECL/dom12
22746        c1 = w1 / (Rhead ** 3.0d0)
22747        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
22748        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
22749        dGCLdOM12 = c1 - c2 + c3
22750        DO k= 1, 3
22751         erhead(k) = Rhead_distance(k)/Rhead
22752        END DO
22753        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22754        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22755        facd1 = d1i * vbld_inv(i+nres)
22756        facd2 = d1j * vbld_inv(j+nres)
22757        DO k = 1, 3
22758
22759         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22760         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22761                   - dGCLdR * pom
22762         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22763         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22764                   + dGCLdR * pom
22765
22766         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22767                   - dGCLdR * erhead(k)
22768         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22769                   + dGCLdR * erhead(k)
22770        END DO
22771        endif
22772 !now charge with dipole eg. ARG-dG
22773        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
22774       alphapol1 = alphapol_scbase(itypi,itypj)
22775        w1        = wqdip_scbase(1,itypi,itypj)
22776        w2        = wqdip_scbase(2,itypi,itypj)
22777 !       w1=0.0d0
22778 !       w2=0.0d0
22779 !       pis       = sig0head_scbase(itypi,itypj)
22780 !       eps_head   = epshead_scbase(itypi,itypj)
22781 !c!-------------------------------------------------------------------
22782 !c! R1 - distance between head of ith side chain and tail of jth sidechain
22783        R1 = 0.0d0
22784        DO k = 1, 3
22785 !c! Calculate head-to-tail distances tail is center of side-chain
22786         R1=R1+(c(k,j+nres)-chead(k,1))**2
22787        END DO
22788 !c! Pitagoras
22789        R1 = dsqrt(R1)
22790
22791 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
22792 !c!     &        +dhead(1,1,itypi,itypj))**2))
22793 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
22794 !c!     &        +dhead(2,1,itypi,itypj))**2))
22795
22796 !c!-------------------------------------------------------------------
22797 !c! ecl
22798        sparrow  = w1  *  om1
22799        hawk     = w2 *  (1.0d0 - sqom2)
22800        Ecl = sparrow / Rhead**2.0d0 &
22801            - hawk    / Rhead**4.0d0
22802 !c!-------------------------------------------------------------------
22803 !c! derivative of ecl is Gcl
22804 !c! dF/dr part
22805        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
22806                 + 4.0d0 * hawk    / Rhead**5.0d0
22807 !c! dF/dom1
22808        dGCLdOM1 = (w1) / (Rhead**2.0d0)
22809 !c! dF/dom2
22810        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
22811 !c--------------------------------------------------------------------
22812 !c Polarization energy
22813 !c Epol
22814        MomoFac1 = (1.0d0 - chi1 * sqom2)
22815        RR1  = R1 * R1 / MomoFac1
22816        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
22817        fgb1 = sqrt( RR1 + a12sq * ee1)
22818 !       eps_inout_fac=0.0d0
22819        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
22820 ! derivative of Epol is Gpol...
22821        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
22822                 / (fgb1 ** 5.0d0)
22823        dFGBdR1 = ( (R1 / MomoFac1) &
22824              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
22825              / ( 2.0d0 * fgb1 )
22826        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
22827                * (2.0d0 - 0.5d0 * ee1) ) &
22828                / (2.0d0 * fgb1)
22829        dPOLdR1 = dPOLdFGB1 * dFGBdR1
22830 !       dPOLdR1 = 0.0d0
22831        dPOLdOM1 = 0.0d0
22832        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
22833        DO k = 1, 3
22834         erhead(k) = Rhead_distance(k)/Rhead
22835         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
22836        END DO
22837
22838        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22839        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22840        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
22841 !       bat=0.0d0
22842        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
22843        facd1 = d1i * vbld_inv(i+nres)
22844        facd2 = d1j * vbld_inv(j+nres)
22845 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22846
22847        DO k = 1, 3
22848         hawk = (erhead_tail(k,1) + &
22849         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
22850 !        facd1=0.0d0
22851 !        facd2=0.0d0
22852         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22853         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
22854                    - dGCLdR * pom &
22855                    - dPOLdR1 *  (erhead_tail(k,1))
22856 !     &             - dGLJdR * pom
22857
22858         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22859         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
22860                    + dGCLdR * pom  &
22861                    + dPOLdR1 * (erhead_tail(k,1))
22862 !     &             + dGLJdR * pom
22863
22864
22865         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
22866                   - dGCLdR * erhead(k) &
22867                   - dPOLdR1 * erhead_tail(k,1)
22868 !     &             - dGLJdR * erhead(k)
22869
22870         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
22871                   + dGCLdR * erhead(k)  &
22872                   + dPOLdR1 * erhead_tail(k,1)
22873 !     &             + dGLJdR * erhead(k)
22874
22875        END DO
22876        endif
22877 !       print *,i,j,evdwij,epol,Fcav,ECL
22878        escbase=escbase+evdwij+epol+Fcav+ECL
22879        call sc_grad_scbase
22880          enddo
22881       enddo
22882
22883       return
22884       end subroutine eprot_sc_base
22885       SUBROUTINE sc_grad_scbase
22886       use calc_data
22887
22888        real (kind=8) :: dcosom1(3),dcosom2(3)
22889        eom1  =    &
22890               eps2der * eps2rt_om1   &
22891             - 2.0D0 * alf1 * eps3der &
22892             + sigder * sigsq_om1     &
22893             + dCAVdOM1               &
22894             + dGCLdOM1               &
22895             + dPOLdOM1
22896
22897        eom2  =  &
22898               eps2der * eps2rt_om2   &
22899             + 2.0D0 * alf2 * eps3der &
22900             + sigder * sigsq_om2     &
22901             + dCAVdOM2               &
22902             + dGCLdOM2               &
22903             + dPOLdOM2
22904
22905        eom12 =    &
22906               evdwij  * eps1_om12     &
22907             + eps2der * eps2rt_om12   &
22908             - 2.0D0 * alf12 * eps3der &
22909             + sigder *sigsq_om12      &
22910             + dCAVdOM12               &
22911             + dGCLdOM12
22912
22913 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
22914 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
22915 !               gg(1),gg(2),"rozne"
22916        DO k = 1, 3
22917         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
22918         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
22919         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
22920         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
22921                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22922                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22923         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
22924                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22925                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22926         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
22927         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
22928        END DO
22929        RETURN
22930       END SUBROUTINE sc_grad_scbase
22931
22932
22933       subroutine epep_sc_base(epepbase)
22934       use calc_data
22935       logical :: lprn
22936 !el local variables
22937       integer :: iint,itypi,itypi1,itypj,subchap
22938       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22939       real(kind=8) :: evdw,sig0ij
22940       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22941                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22942                     sslipi,sslipj,faclip
22943       integer :: ii
22944       real(kind=8) :: fracinbuf
22945        real (kind=8) :: epepbase
22946        real (kind=8),dimension(4):: ener
22947        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22948        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22949         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22950         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22951         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22952         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22953         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22954         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22955        real(kind=8),dimension(3,2)::chead,erhead_tail
22956        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22957        integer troll
22958        eps_out=80.0d0
22959        epepbase=0.0d0
22960 !       do i=1,nres_molec(1)-1
22961         do i=ibond_start,ibond_end
22962         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
22963 !C        itypi  = itype(i,1)
22964         dxi    = dc_norm(1,i)
22965         dyi    = dc_norm(2,i)
22966         dzi    = dc_norm(3,i)
22967 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
22968         dsci_inv = vbld_inv(i+1)/2.0
22969         xi=(c(1,i)+c(1,i+1))/2.0
22970         yi=(c(2,i)+c(2,i+1))/2.0
22971         zi=(c(3,i)+c(3,i+1))/2.0
22972         xi=mod(xi,boxxsize)
22973          if (xi.lt.0) xi=xi+boxxsize
22974         yi=mod(yi,boxysize)
22975          if (yi.lt.0) yi=yi+boxysize
22976         zi=mod(zi,boxzsize)
22977          if (zi.lt.0) zi=zi+boxzsize
22978          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22979            itypj= itype(j,2)
22980            if (itype(j,2).eq.ntyp1_molec(2))cycle
22981            xj=c(1,j+nres)
22982            yj=c(2,j+nres)
22983            zj=c(3,j+nres)
22984            xj=dmod(xj,boxxsize)
22985            if (xj.lt.0) xj=xj+boxxsize
22986            yj=dmod(yj,boxysize)
22987            if (yj.lt.0) yj=yj+boxysize
22988            zj=dmod(zj,boxzsize)
22989            if (zj.lt.0) zj=zj+boxzsize
22990           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22991           xj_safe=xj
22992           yj_safe=yj
22993           zj_safe=zj
22994           subchap=0
22995
22996           do xshift=-1,1
22997           do yshift=-1,1
22998           do zshift=-1,1
22999           xj=xj_safe+xshift*boxxsize
23000           yj=yj_safe+yshift*boxysize
23001           zj=zj_safe+zshift*boxzsize
23002           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23003           if(dist_temp.lt.dist_init) then
23004             dist_init=dist_temp
23005             xj_temp=xj
23006             yj_temp=yj
23007             zj_temp=zj
23008             subchap=1
23009           endif
23010           enddo
23011           enddo
23012           enddo
23013           if (subchap.eq.1) then
23014           xj=xj_temp-xi
23015           yj=yj_temp-yi
23016           zj=zj_temp-zi
23017           else
23018           xj=xj_safe-xi
23019           yj=yj_safe-yi
23020           zj=zj_safe-zi
23021           endif
23022           dxj = dc_norm( 1, nres+j )
23023           dyj = dc_norm( 2, nres+j )
23024           dzj = dc_norm( 3, nres+j )
23025 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23026 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23027
23028 ! Gay-berne var's
23029           sig0ij = sigma_pepbase(itypj )
23030           chi1   = chi_pepbase(itypj,1 )
23031           chi2   = chi_pepbase(itypj,2 )
23032 !          chi1=0.0d0
23033 !          chi2=0.0d0
23034           chi12  = chi1 * chi2
23035           chip1  = chipp_pepbase(itypj,1 )
23036           chip2  = chipp_pepbase(itypj,2 )
23037 !          chip1=0.0d0
23038 !          chip2=0.0d0
23039           chip12 = chip1 * chip2
23040           chis1 = chis_pepbase(itypj,1)
23041           chis2 = chis_pepbase(itypj,2)
23042           chis12 = chis1 * chis2
23043           sig1 = sigmap1_pepbase(itypj)
23044           sig2 = sigmap2_pepbase(itypj)
23045 !       write (*,*) "sig1 = ", sig1
23046 !       write (*,*) "sig2 = ", sig2
23047        DO k = 1,3
23048 ! location of polar head is computed by taking hydrophobic centre
23049 ! and moving by a d1 * dc_norm vector
23050 ! see unres publications for very informative images
23051         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23052 ! + d1i * dc_norm(k, i+nres)
23053         chead(k,2) = c(k, j+nres)
23054 ! + d1j * dc_norm(k, j+nres)
23055 ! distance
23056 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23057 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23058         Rhead_distance(k) = chead(k,2) - chead(k,1)
23059 !        print *,gvdwc_pepbase(k,i)
23060
23061        END DO
23062        Rhead = dsqrt( &
23063           (Rhead_distance(1)*Rhead_distance(1)) &
23064         + (Rhead_distance(2)*Rhead_distance(2)) &
23065         + (Rhead_distance(3)*Rhead_distance(3)))
23066
23067 ! alpha factors from Fcav/Gcav
23068           b1 = alphasur_pepbase(1,itypj)
23069 !          b1=0.0d0
23070           b2 = alphasur_pepbase(2,itypj)
23071           b3 = alphasur_pepbase(3,itypj)
23072           b4 = alphasur_pepbase(4,itypj)
23073           alf1   = 0.0d0
23074           alf2   = 0.0d0
23075           alf12  = 0.0d0
23076           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23077 !          print *,i,j,rrij
23078           rij  = dsqrt(rrij)
23079 !----------------------------
23080        evdwij = 0.0d0
23081        ECL = 0.0d0
23082        Elj = 0.0d0
23083        Equad = 0.0d0
23084        Epol = 0.0d0
23085        Fcav=0.0d0
23086        eheadtail = 0.0d0
23087        dGCLdOM1 = 0.0d0
23088        dGCLdOM2 = 0.0d0
23089        dGCLdOM12 = 0.0d0
23090        dPOLdOM1 = 0.0d0
23091        dPOLdOM2 = 0.0d0
23092           Fcav = 0.0d0
23093           dFdR = 0.0d0
23094           dCAVdOM1  = 0.0d0
23095           dCAVdOM2  = 0.0d0
23096           dCAVdOM12 = 0.0d0
23097           dscj_inv = vbld_inv(j+nres)
23098           CALL sc_angular
23099 ! this should be in elgrad_init but om's are calculated by sc_angular
23100 ! which in turn is used by older potentials
23101 ! om = omega, sqom = om^2
23102           sqom1  = om1 * om1
23103           sqom2  = om2 * om2
23104           sqom12 = om12 * om12
23105
23106 ! now we calculate EGB - Gey-Berne
23107 ! It will be summed up in evdwij and saved in evdw
23108           sigsq     = 1.0D0  / sigsq
23109           sig       = sig0ij * dsqrt(sigsq)
23110           rij_shift = 1.0/rij - sig + sig0ij
23111           IF (rij_shift.le.0.0D0) THEN
23112            evdw = 1.0D20
23113            RETURN
23114           END IF
23115           sigder = -sig * sigsq
23116           rij_shift = 1.0D0 / rij_shift
23117           fac       = rij_shift**expon
23118           c1        = fac  * fac * aa_pepbase(itypj)
23119 !          c1        = 0.0d0
23120           c2        = fac  * bb_pepbase(itypj)
23121 !          c2        = 0.0d0
23122           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23123           eps2der   = eps3rt * evdwij
23124           eps3der   = eps2rt * evdwij
23125 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23126           evdwij    = eps2rt * eps3rt * evdwij
23127           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23128           fac    = -expon * (c1 + evdwij) * rij_shift
23129           sigder = fac * sigder
23130 !          fac    = rij * fac
23131 ! Calculate distance derivative
23132           gg(1) =  fac
23133           gg(2) =  fac
23134           gg(3) =  fac
23135           fac = chis1 * sqom1 + chis2 * sqom2 &
23136           - 2.0d0 * chis12 * om1 * om2 * om12
23137 ! we will use pom later in Gcav, so dont mess with it!
23138           pom = 1.0d0 - chis1 * chis2 * sqom12
23139           Lambf = (1.0d0 - (fac / pom))
23140           Lambf = dsqrt(Lambf)
23141           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23142 !       write (*,*) "sparrow = ", sparrow
23143           Chif = 1.0d0/rij * sparrow
23144           ChiLambf = Chif * Lambf
23145           eagle = dsqrt(ChiLambf)
23146           bat = ChiLambf ** 11.0d0
23147           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23148           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23149           botsq = bot * bot
23150           Fcav = top / bot
23151 !          print *,i,j,Fcav
23152           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23153           dbot = 12.0d0 * b4 * bat * Lambf
23154           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23155 !       dFdR = 0.0d0
23156 !      write (*,*) "dFcav/dR = ", dFdR
23157           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23158           dbot = 12.0d0 * b4 * bat * Chif
23159           eagle = Lambf * pom
23160           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23161           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23162           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23163               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23164
23165           dFdL = ((dtop * bot - top * dbot) / botsq)
23166 !       dFdL = 0.0d0
23167           dCAVdOM1  = dFdL * ( dFdOM1 )
23168           dCAVdOM2  = dFdL * ( dFdOM2 )
23169           dCAVdOM12 = dFdL * ( dFdOM12 )
23170
23171           ertail(1) = xj*rij
23172           ertail(2) = yj*rij
23173           ertail(3) = zj*rij
23174        DO k = 1, 3
23175 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23176 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23177         pom = ertail(k)
23178 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23179         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23180                   - (( dFdR + gg(k) ) * pom)/2.0
23181 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
23182 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23183 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23184 !     &             - ( dFdR * pom )
23185         pom = ertail(k)
23186 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23187         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23188                   + (( dFdR + gg(k) ) * pom)
23189 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23190 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23191 !c!     &             + ( dFdR * pom )
23192
23193         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23194                   - (( dFdR + gg(k) ) * ertail(k))/2.0
23195 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
23196
23197 !c!     &             - ( dFdR * ertail(k))
23198
23199         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23200                   + (( dFdR + gg(k) ) * ertail(k))
23201 !c!     &             + ( dFdR * ertail(k))
23202
23203         gg(k) = 0.0d0
23204 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23205 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23206       END DO
23207
23208
23209        w1 = wdipdip_pepbase(1,itypj)
23210        w2 = -wdipdip_pepbase(3,itypj)/2.0
23211        w3 = wdipdip_pepbase(2,itypj)
23212 !       w1=0.0d0
23213 !       w2=0.0d0
23214 !c!-------------------------------------------------------------------
23215 !c! ECL
23216 !       w3=0.0d0
23217        fac = (om12 - 3.0d0 * om1 * om2)
23218        c1 = (w1 / (Rhead**3.0d0)) * fac
23219        c2 = (w2 / Rhead ** 6.0d0)  &
23220          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23221        c3= (w3/ Rhead ** 6.0d0)  &
23222          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23223
23224        ECL = c1 - c2 + c3
23225
23226        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23227        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23228          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23229        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23230          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23231
23232        dGCLdR = c1 - c2 + c3
23233 !c! dECL/dom1
23234        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23235        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23236          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23237        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23238        dGCLdOM1 = c1 - c2 + c3
23239 !c! dECL/dom2
23240        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23241        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23242          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23243        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23244
23245        dGCLdOM2 = c1 - c2 + c3
23246 !c! dECL/dom12
23247        c1 = w1 / (Rhead ** 3.0d0)
23248        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23249        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23250        dGCLdOM12 = c1 - c2 + c3
23251        DO k= 1, 3
23252         erhead(k) = Rhead_distance(k)/Rhead
23253        END DO
23254        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23255        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23256 !       facd1 = d1 * vbld_inv(i+nres)
23257 !       facd2 = d2 * vbld_inv(j+nres)
23258        DO k = 1, 3
23259
23260 !        pom = erhead(k)
23261 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23262 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
23263 !                  - dGCLdR * pom
23264         pom = erhead(k)
23265 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23266         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23267                   + dGCLdR * pom
23268
23269         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23270                   - dGCLdR * erhead(k)/2.0d0
23271 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23272         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23273                   - dGCLdR * erhead(k)/2.0d0
23274 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23275         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23276                   + dGCLdR * erhead(k)
23277        END DO
23278 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
23279        epepbase=epepbase+evdwij+Fcav+ECL
23280        call sc_grad_pepbase
23281        enddo
23282        enddo
23283       END SUBROUTINE epep_sc_base
23284       SUBROUTINE sc_grad_pepbase
23285       use calc_data
23286
23287        real (kind=8) :: dcosom1(3),dcosom2(3)
23288        eom1  =    &
23289               eps2der * eps2rt_om1   &
23290             - 2.0D0 * alf1 * eps3der &
23291             + sigder * sigsq_om1     &
23292             + dCAVdOM1               &
23293             + dGCLdOM1               &
23294             + dPOLdOM1
23295
23296        eom2  =  &
23297               eps2der * eps2rt_om2   &
23298             + 2.0D0 * alf2 * eps3der &
23299             + sigder * sigsq_om2     &
23300             + dCAVdOM2               &
23301             + dGCLdOM2               &
23302             + dPOLdOM2
23303
23304        eom12 =    &
23305               evdwij  * eps1_om12     &
23306             + eps2der * eps2rt_om12   &
23307             - 2.0D0 * alf12 * eps3der &
23308             + sigder *sigsq_om12      &
23309             + dCAVdOM12               &
23310             + dGCLdOM12
23311 !        om12=0.0
23312 !        eom12=0.0
23313 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23314 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
23315 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23316 !                 *dsci_inv*2.0
23317 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23318 !               gg(1),gg(2),"rozne"
23319        DO k = 1, 3
23320         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
23321         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23322         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23323         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
23324                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23325                  *dsci_inv*2.0 &
23326                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23327         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
23328                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
23329                  *dsci_inv*2.0 &
23330                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23331 !         print *,eom12,eom2,om12,om2
23332 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23333 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23334         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
23335                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23336                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23337         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
23338        END DO
23339        RETURN
23340       END SUBROUTINE sc_grad_pepbase
23341       subroutine eprot_sc_phosphate(escpho)
23342       use calc_data
23343 !      implicit real*8 (a-h,o-z)
23344 !      include 'DIMENSIONS'
23345 !      include 'COMMON.GEO'
23346 !      include 'COMMON.VAR'
23347 !      include 'COMMON.LOCAL'
23348 !      include 'COMMON.CHAIN'
23349 !      include 'COMMON.DERIV'
23350 !      include 'COMMON.NAMES'
23351 !      include 'COMMON.INTERACT'
23352 !      include 'COMMON.IOUNITS'
23353 !      include 'COMMON.CALC'
23354 !      include 'COMMON.CONTROL'
23355 !      include 'COMMON.SBRIDGE'
23356       logical :: lprn
23357 !el local variables
23358       integer :: iint,itypi,itypi1,itypj,subchap
23359       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23360       real(kind=8) :: evdw,sig0ij
23361       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23362                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23363                     sslipi,sslipj,faclip
23364       integer :: ii
23365       real(kind=8) :: fracinbuf
23366        real (kind=8) :: escpho
23367        real (kind=8),dimension(4):: ener
23368        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23369        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23370         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23371         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23372         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23373         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23374         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23375         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23376        real(kind=8),dimension(3,2)::chead,erhead_tail
23377        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23378        integer troll
23379        eps_out=80.0d0
23380        escpho=0.0d0
23381 !       do i=1,nres_molec(1)
23382         do i=ibond_start,ibond_end
23383         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23384         itypi  = itype(i,1)
23385         dxi    = dc_norm(1,nres+i)
23386         dyi    = dc_norm(2,nres+i)
23387         dzi    = dc_norm(3,nres+i)
23388         dsci_inv = vbld_inv(i+nres)
23389         xi=c(1,nres+i)
23390         yi=c(2,nres+i)
23391         zi=c(3,nres+i)
23392         xi=mod(xi,boxxsize)
23393          if (xi.lt.0) xi=xi+boxxsize
23394         yi=mod(yi,boxysize)
23395          if (yi.lt.0) yi=yi+boxysize
23396         zi=mod(zi,boxzsize)
23397          if (zi.lt.0) zi=zi+boxzsize
23398          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23399            itypj= itype(j,2)
23400            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23401             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23402            xj=(c(1,j)+c(1,j+1))/2.0
23403            yj=(c(2,j)+c(2,j+1))/2.0
23404            zj=(c(3,j)+c(3,j+1))/2.0
23405            xj=dmod(xj,boxxsize)
23406            if (xj.lt.0) xj=xj+boxxsize
23407            yj=dmod(yj,boxysize)
23408            if (yj.lt.0) yj=yj+boxysize
23409            zj=dmod(zj,boxzsize)
23410            if (zj.lt.0) zj=zj+boxzsize
23411           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23412           xj_safe=xj
23413           yj_safe=yj
23414           zj_safe=zj
23415           subchap=0
23416           do xshift=-1,1
23417           do yshift=-1,1
23418           do zshift=-1,1
23419           yj=yj_safe+yshift*boxysize
23420           zj=zj_safe+zshift*boxzsize
23421           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23422           if(dist_temp.lt.dist_init) then
23423             dist_init=dist_temp
23424             xj_temp=xj
23425             yj_temp=yj
23426             zj_temp=zj
23427             subchap=1
23428           endif
23429           enddo
23430           enddo
23431           enddo
23432           if (subchap.eq.1) then
23433           xj=xj_temp-xi
23434           yj=yj_temp-yi
23435           zj=zj_temp-zi
23436           else
23437           xj=xj_safe-xi
23438           yj=yj_safe-yi
23439           zj=zj_safe-zi
23440           endif
23441           dxj = dc_norm( 1,j )
23442           dyj = dc_norm( 2,j )
23443           dzj = dc_norm( 3,j )
23444           dscj_inv = vbld_inv(j+1)
23445
23446 ! Gay-berne var's
23447           sig0ij = sigma_scpho(itypi )
23448           chi1   = chi_scpho(itypi,1 )
23449           chi2   = chi_scpho(itypi,2 )
23450 !          chi1=0.0d0
23451 !          chi2=0.0d0
23452           chi12  = chi1 * chi2
23453           chip1  = chipp_scpho(itypi,1 )
23454           chip2  = chipp_scpho(itypi,2 )
23455 !          chip1=0.0d0
23456 !          chip2=0.0d0
23457           chip12 = chip1 * chip2
23458           chis1 = chis_scpho(itypi,1)
23459           chis2 = chis_scpho(itypi,2)
23460           chis12 = chis1 * chis2
23461           sig1 = sigmap1_scpho(itypi)
23462           sig2 = sigmap2_scpho(itypi)
23463 !       write (*,*) "sig1 = ", sig1
23464 !       write (*,*) "sig1 = ", sig1
23465 !       write (*,*) "sig2 = ", sig2
23466 ! alpha factors from Fcav/Gcav
23467           alf1   = 0.0d0
23468           alf2   = 0.0d0
23469           alf12  = 0.0d0
23470           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
23471
23472           b1 = alphasur_scpho(1,itypi)
23473 !          b1=0.0d0
23474           b2 = alphasur_scpho(2,itypi)
23475           b3 = alphasur_scpho(3,itypi)
23476           b4 = alphasur_scpho(4,itypi)
23477 ! used to determine whether we want to do quadrupole calculations
23478 ! used by Fgb
23479        eps_in = epsintab_scpho(itypi)
23480        if (eps_in.eq.0.0) eps_in=1.0
23481        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23482 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23483 !-------------------------------------------------------------------
23484 ! tail location and distance calculations
23485           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
23486           d1j = 0.0
23487        DO k = 1,3
23488 ! location of polar head is computed by taking hydrophobic centre
23489 ! and moving by a d1 * dc_norm vector
23490 ! see unres publications for very informative images
23491         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23492         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
23493 ! distance
23494 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23495 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23496         Rhead_distance(k) = chead(k,2) - chead(k,1)
23497        END DO
23498 ! pitagoras (root of sum of squares)
23499        Rhead = dsqrt( &
23500           (Rhead_distance(1)*Rhead_distance(1)) &
23501         + (Rhead_distance(2)*Rhead_distance(2)) &
23502         + (Rhead_distance(3)*Rhead_distance(3)))
23503        Rhead_sq=Rhead**2.0
23504 !-------------------------------------------------------------------
23505 ! zero everything that should be zero'ed
23506        evdwij = 0.0d0
23507        ECL = 0.0d0
23508        Elj = 0.0d0
23509        Equad = 0.0d0
23510        Epol = 0.0d0
23511        Fcav=0.0d0
23512        eheadtail = 0.0d0
23513        dGCLdR=0.0d0
23514        dGCLdOM1 = 0.0d0
23515        dGCLdOM2 = 0.0d0
23516        dGCLdOM12 = 0.0d0
23517        dPOLdOM1 = 0.0d0
23518        dPOLdOM2 = 0.0d0
23519           Fcav = 0.0d0
23520           dFdR = 0.0d0
23521           dCAVdOM1  = 0.0d0
23522           dCAVdOM2  = 0.0d0
23523           dCAVdOM12 = 0.0d0
23524           dscj_inv = vbld_inv(j+1)/2.0
23525 !dhead_scbasej(itypi,itypj)
23526 !          print *,i,j,dscj_inv,dsci_inv
23527 ! rij holds 1/(distance of Calpha atoms)
23528           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23529           rij  = dsqrt(rrij)
23530 !----------------------------
23531           CALL sc_angular
23532 ! this should be in elgrad_init but om's are calculated by sc_angular
23533 ! which in turn is used by older potentials
23534 ! om = omega, sqom = om^2
23535           sqom1  = om1 * om1
23536           sqom2  = om2 * om2
23537           sqom12 = om12 * om12
23538
23539 ! now we calculate EGB - Gey-Berne
23540 ! It will be summed up in evdwij and saved in evdw
23541           sigsq     = 1.0D0  / sigsq
23542           sig       = sig0ij * dsqrt(sigsq)
23543 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23544           rij_shift = 1.0/rij - sig + sig0ij
23545           IF (rij_shift.le.0.0D0) THEN
23546            evdw = 1.0D20
23547            RETURN
23548           END IF
23549           sigder = -sig * sigsq
23550           rij_shift = 1.0D0 / rij_shift
23551           fac       = rij_shift**expon
23552           c1        = fac  * fac * aa_scpho(itypi)
23553 !          c1        = 0.0d0
23554           c2        = fac  * bb_scpho(itypi)
23555 !          c2        = 0.0d0
23556           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23557           eps2der   = eps3rt * evdwij
23558           eps3der   = eps2rt * evdwij
23559 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23560           evdwij    = eps2rt * eps3rt * evdwij
23561           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23562           fac    = -expon * (c1 + evdwij) * rij_shift
23563           sigder = fac * sigder
23564 !          fac    = rij * fac
23565 ! Calculate distance derivative
23566           gg(1) =  fac
23567           gg(2) =  fac
23568           gg(3) =  fac
23569           fac = chis1 * sqom1 + chis2 * sqom2 &
23570           - 2.0d0 * chis12 * om1 * om2 * om12
23571 ! we will use pom later in Gcav, so dont mess with it!
23572           pom = 1.0d0 - chis1 * chis2 * sqom12
23573           Lambf = (1.0d0 - (fac / pom))
23574           Lambf = dsqrt(Lambf)
23575           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23576 !       write (*,*) "sparrow = ", sparrow
23577           Chif = 1.0d0/rij * sparrow
23578           ChiLambf = Chif * Lambf
23579           eagle = dsqrt(ChiLambf)
23580           bat = ChiLambf ** 11.0d0
23581           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23582           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23583           botsq = bot * bot
23584           Fcav = top / bot
23585           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23586           dbot = 12.0d0 * b4 * bat * Lambf
23587           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23588 !       dFdR = 0.0d0
23589 !      write (*,*) "dFcav/dR = ", dFdR
23590           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23591           dbot = 12.0d0 * b4 * bat * Chif
23592           eagle = Lambf * pom
23593           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23594           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23595           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23596               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23597
23598           dFdL = ((dtop * bot - top * dbot) / botsq)
23599 !       dFdL = 0.0d0
23600           dCAVdOM1  = dFdL * ( dFdOM1 )
23601           dCAVdOM2  = dFdL * ( dFdOM2 )
23602           dCAVdOM12 = dFdL * ( dFdOM12 )
23603
23604           ertail(1) = xj*rij
23605           ertail(2) = yj*rij
23606           ertail(3) = zj*rij
23607        DO k = 1, 3
23608 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23609 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23610 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
23611
23612         pom = ertail(k)
23613 !        print *,pom,gg(k),dFdR
23614 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23615         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
23616                   - (( dFdR + gg(k) ) * pom)
23617 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23618 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23619 !     &             - ( dFdR * pom )
23620 !        pom = ertail(k)
23621 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23622 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
23623 !                  + (( dFdR + gg(k) ) * pom)
23624 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23625 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23626 !c!     &             + ( dFdR * pom )
23627
23628         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
23629                   - (( dFdR + gg(k) ) * ertail(k))
23630 !c!     &             - ( dFdR * ertail(k))
23631
23632         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
23633                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23634
23635         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
23636                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23637
23638 !c!     &             + ( dFdR * ertail(k))
23639
23640         gg(k) = 0.0d0
23641         ENDDO
23642 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23643 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23644 !      alphapol1 = alphapol_scpho(itypi)
23645        if (wqq_scpho(itypi).gt.0.0) then
23646        Qij=wqq_scpho(itypi)/eps_in
23647 !       Qij=0.0
23648        Ecl = (332.0d0 * Qij) / Rhead
23649 !c! derivative of Ecl is Gcl...
23650        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
23651        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
23652        w1        = wqdip_scpho(1,itypi)
23653        w2        = wqdip_scpho(2,itypi)
23654 !       w1=0.0d0
23655 !       w2=0.0d0
23656 !       pis       = sig0head_scbase(itypi,itypj)
23657 !       eps_head   = epshead_scbase(itypi,itypj)
23658 !c!-------------------------------------------------------------------
23659
23660 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23661 !c!     &        +dhead(1,1,itypi,itypj))**2))
23662 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23663 !c!     &        +dhead(2,1,itypi,itypj))**2))
23664
23665 !c!-------------------------------------------------------------------
23666 !c! ecl
23667        sparrow  = w1  *  om1
23668        hawk     = w2 *  (1.0d0 - sqom2)
23669        Ecl = sparrow / Rhead**2.0d0 &
23670            - hawk    / Rhead**4.0d0
23671 !c!-------------------------------------------------------------------
23672 !c! derivative of ecl is Gcl
23673 !c! dF/dr part
23674        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23675                 + 4.0d0 * hawk    / Rhead**5.0d0
23676 !c! dF/dom1
23677        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23678 !c! dF/dom2
23679        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23680        endif
23681
23682 !c--------------------------------------------------------------------
23683 !c Polarization energy
23684 !c Epol
23685        R1 = 0.0d0
23686        DO k = 1, 3
23687 !c! Calculate head-to-tail distances tail is center of side-chain
23688         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
23689        END DO
23690 !c! Pitagoras
23691        R1 = dsqrt(R1)
23692
23693       alphapol1 = alphapol_scpho(itypi)
23694 !      alphapol1=0.0
23695        MomoFac1 = (1.0d0 - chi2 * sqom1)
23696        RR1  = R1 * R1 / MomoFac1
23697        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23698 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
23699        fgb1 = sqrt( RR1 + a12sq * ee1)
23700 !       eps_inout_fac=0.0d0
23701        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23702 ! derivative of Epol is Gpol...
23703        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23704                 / (fgb1 ** 5.0d0)
23705        dFGBdR1 = ( (R1 / MomoFac1) &
23706              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23707              / ( 2.0d0 * fgb1 )
23708        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23709                * (2.0d0 - 0.5d0 * ee1) ) &
23710                / (2.0d0 * fgb1)
23711        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23712 !       dPOLdR1 = 0.0d0
23713 !       dPOLdOM1 = 0.0d0
23714        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
23715                * (2.0d0 - 0.5d0 * ee1) ) &
23716                / (2.0d0 * fgb1)
23717
23718        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
23719        dPOLdOM2 = 0.0
23720        DO k = 1, 3
23721         erhead(k) = Rhead_distance(k)/Rhead
23722         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
23723        END DO
23724
23725        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23726        erdxj = scalar( erhead(1), dC_norm(1,j) )
23727        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23728 !       bat=0.0d0
23729        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
23730        facd1 = d1i * vbld_inv(i+nres)
23731        facd2 = d1j * vbld_inv(j)
23732 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23733
23734        DO k = 1, 3
23735         hawk = (erhead_tail(k,1) + &
23736         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23737 !        facd1=0.0d0
23738 !        facd2=0.0d0
23739 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
23740 !                pom,(erhead_tail(k,1))
23741
23742 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
23743         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23744         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
23745                    - dGCLdR * pom &
23746                    - dPOLdR1 *  (erhead_tail(k,1))
23747 !     &             - dGLJdR * pom
23748
23749         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
23750 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
23751 !                   + dGCLdR * pom  &
23752 !                   + dPOLdR1 * (erhead_tail(k,1))
23753 !     &             + dGLJdR * pom
23754
23755
23756         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
23757                   - dGCLdR * erhead(k) &
23758                   - dPOLdR1 * erhead_tail(k,1)
23759 !     &             - dGLJdR * erhead(k)
23760
23761         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
23762                   + (dGCLdR * erhead(k)  &
23763                   + dPOLdR1 * erhead_tail(k,1))/2.0
23764         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
23765                   + (dGCLdR * erhead(k)  &
23766                   + dPOLdR1 * erhead_tail(k,1))/2.0
23767
23768 !     &             + dGLJdR * erhead(k)
23769 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
23770
23771        END DO
23772 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
23773        escpho=escpho+evdwij+epol+Fcav+ECL
23774        call sc_grad_scpho
23775          enddo
23776
23777       enddo
23778
23779       return
23780       end subroutine eprot_sc_phosphate
23781       SUBROUTINE sc_grad_scpho
23782       use calc_data
23783
23784        real (kind=8) :: dcosom1(3),dcosom2(3)
23785        eom1  =    &
23786               eps2der * eps2rt_om1   &
23787             - 2.0D0 * alf1 * eps3der &
23788             + sigder * sigsq_om1     &
23789             + dCAVdOM1               &
23790             + dGCLdOM1               &
23791             + dPOLdOM1
23792
23793        eom2  =  &
23794               eps2der * eps2rt_om2   &
23795             + 2.0D0 * alf2 * eps3der &
23796             + sigder * sigsq_om2     &
23797             + dCAVdOM2               &
23798             + dGCLdOM2               &
23799             + dPOLdOM2
23800
23801        eom12 =    &
23802               evdwij  * eps1_om12     &
23803             + eps2der * eps2rt_om12   &
23804             - 2.0D0 * alf12 * eps3der &
23805             + sigder *sigsq_om12      &
23806             + dCAVdOM12               &
23807             + dGCLdOM12
23808 !        om12=0.0
23809 !        eom12=0.0
23810 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23811 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
23812 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23813 !                 *dsci_inv*2.0
23814 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23815 !               gg(1),gg(2),"rozne"
23816        DO k = 1, 3
23817         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23818         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
23819         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23820         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
23821                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
23822                  *dscj_inv*2.0 &
23823                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23824         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
23825                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
23826                  *dscj_inv*2.0 &
23827                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23828         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
23829                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
23830                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23831
23832 !         print *,eom12,eom2,om12,om2
23833 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23834 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23835 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
23836 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23837 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23838         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
23839        END DO
23840        RETURN
23841       END SUBROUTINE sc_grad_scpho
23842       subroutine eprot_pep_phosphate(epeppho)
23843       use calc_data
23844 !      implicit real*8 (a-h,o-z)
23845 !      include 'DIMENSIONS'
23846 !      include 'COMMON.GEO'
23847 !      include 'COMMON.VAR'
23848 !      include 'COMMON.LOCAL'
23849 !      include 'COMMON.CHAIN'
23850 !      include 'COMMON.DERIV'
23851 !      include 'COMMON.NAMES'
23852 !      include 'COMMON.INTERACT'
23853 !      include 'COMMON.IOUNITS'
23854 !      include 'COMMON.CALC'
23855 !      include 'COMMON.CONTROL'
23856 !      include 'COMMON.SBRIDGE'
23857       logical :: lprn
23858 !el local variables
23859       integer :: iint,itypi,itypi1,itypj,subchap
23860       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23861       real(kind=8) :: evdw,sig0ij
23862       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23863                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23864                     sslipi,sslipj,faclip
23865       integer :: ii
23866       real(kind=8) :: fracinbuf
23867        real (kind=8) :: epeppho
23868        real (kind=8),dimension(4):: ener
23869        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23870        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23871         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23872         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23873         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23874         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23875         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23876         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23877        real(kind=8),dimension(3,2)::chead,erhead_tail
23878        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23879        integer troll
23880        real (kind=8) :: dcosom1(3),dcosom2(3)
23881        epeppho=0.0d0
23882 !       do i=1,nres_molec(1)
23883         do i=ibond_start,ibond_end
23884         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23885         itypi  = itype(i,1)
23886         dsci_inv = vbld_inv(i+1)/2.0
23887         dxi    = dc_norm(1,i)
23888         dyi    = dc_norm(2,i)
23889         dzi    = dc_norm(3,i)
23890         xi=(c(1,i)+c(1,i+1))/2.0
23891         yi=(c(2,i)+c(2,i+1))/2.0
23892         zi=(c(3,i)+c(3,i+1))/2.0
23893         xi=mod(xi,boxxsize)
23894          if (xi.lt.0) xi=xi+boxxsize
23895         yi=mod(yi,boxysize)
23896          if (yi.lt.0) yi=yi+boxysize
23897         zi=mod(zi,boxzsize)
23898          if (zi.lt.0) zi=zi+boxzsize
23899          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23900            itypj= itype(j,2)
23901            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23902             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23903            xj=(c(1,j)+c(1,j+1))/2.0
23904            yj=(c(2,j)+c(2,j+1))/2.0
23905            zj=(c(3,j)+c(3,j+1))/2.0
23906            xj=dmod(xj,boxxsize)
23907            if (xj.lt.0) xj=xj+boxxsize
23908            yj=dmod(yj,boxysize)
23909            if (yj.lt.0) yj=yj+boxysize
23910            zj=dmod(zj,boxzsize)
23911            if (zj.lt.0) zj=zj+boxzsize
23912           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23913           xj_safe=xj
23914           yj_safe=yj
23915           zj_safe=zj
23916           subchap=0
23917           do xshift=-1,1
23918           do yshift=-1,1
23919           do zshift=-1,1
23920           yj=yj_safe+yshift*boxysize
23921           zj=zj_safe+zshift*boxzsize
23922           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23923           if(dist_temp.lt.dist_init) then
23924             dist_init=dist_temp
23925             xj_temp=xj
23926             yj_temp=yj
23927             zj_temp=zj
23928             subchap=1
23929           endif
23930           enddo
23931           enddo
23932           enddo
23933           if (subchap.eq.1) then
23934           xj=xj_temp-xi
23935           yj=yj_temp-yi
23936           zj=zj_temp-zi
23937           else
23938           xj=xj_safe-xi
23939           yj=yj_safe-yi
23940           zj=zj_safe-zi
23941           endif
23942           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23943           rij  = dsqrt(rrij)
23944           dxj = dc_norm( 1,j )
23945           dyj = dc_norm( 2,j )
23946           dzj = dc_norm( 3,j )
23947           dscj_inv = vbld_inv(j+1)/2.0
23948 ! Gay-berne var's
23949           sig0ij = sigma_peppho
23950           chi1=0.0d0
23951           chi2=0.0d0
23952           chi12  = chi1 * chi2
23953           chip1=0.0d0
23954           chip2=0.0d0
23955           chip12 = chip1 * chip2
23956           chis1 = 0.0d0
23957           chis2 = 0.0d0
23958           chis12 = chis1 * chis2
23959           sig1 = sigmap1_peppho
23960           sig2 = sigmap2_peppho
23961 !       write (*,*) "sig1 = ", sig1
23962 !       write (*,*) "sig1 = ", sig1
23963 !       write (*,*) "sig2 = ", sig2
23964 ! alpha factors from Fcav/Gcav
23965           alf1   = 0.0d0
23966           alf2   = 0.0d0
23967           alf12  = 0.0d0
23968           b1 = alphasur_peppho(1)
23969 !          b1=0.0d0
23970           b2 = alphasur_peppho(2)
23971           b3 = alphasur_peppho(3)
23972           b4 = alphasur_peppho(4)
23973           CALL sc_angular
23974        sqom1=om1*om1
23975        evdwij = 0.0d0
23976        ECL = 0.0d0
23977        Elj = 0.0d0
23978        Equad = 0.0d0
23979        Epol = 0.0d0
23980        Fcav=0.0d0
23981        eheadtail = 0.0d0
23982        dGCLdR=0.0d0
23983        dGCLdOM1 = 0.0d0
23984        dGCLdOM2 = 0.0d0
23985        dGCLdOM12 = 0.0d0
23986        dPOLdOM1 = 0.0d0
23987        dPOLdOM2 = 0.0d0
23988           Fcav = 0.0d0
23989           dFdR = 0.0d0
23990           dCAVdOM1  = 0.0d0
23991           dCAVdOM2  = 0.0d0
23992           dCAVdOM12 = 0.0d0
23993           rij_shift = rij
23994           fac       = rij_shift**expon
23995           c1        = fac  * fac * aa_peppho
23996 !          c1        = 0.0d0
23997           c2        = fac  * bb_peppho
23998 !          c2        = 0.0d0
23999           evdwij    =  c1 + c2
24000 ! Now cavity....................
24001        eagle = dsqrt(1.0/rij_shift)
24002        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24003           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24004           botsq = bot * bot
24005           Fcav = top / bot
24006           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24007           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24008           dFdR = ((dtop * bot - top * dbot) / botsq)
24009        w1        = wqdip_peppho(1)
24010        w2        = wqdip_peppho(2)
24011 !       w1=0.0d0
24012 !       w2=0.0d0
24013 !       pis       = sig0head_scbase(itypi,itypj)
24014 !       eps_head   = epshead_scbase(itypi,itypj)
24015 !c!-------------------------------------------------------------------
24016
24017 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24018 !c!     &        +dhead(1,1,itypi,itypj))**2))
24019 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24020 !c!     &        +dhead(2,1,itypi,itypj))**2))
24021
24022 !c!-------------------------------------------------------------------
24023 !c! ecl
24024        sparrow  = w1  *  om1
24025        hawk     = w2 *  (1.0d0 - sqom1)
24026        Ecl = sparrow * rij_shift**2.0d0 &
24027            - hawk    * rij_shift**4.0d0
24028 !c!-------------------------------------------------------------------
24029 !c! derivative of ecl is Gcl
24030 !c! dF/dr part
24031 !       rij_shift=5.0
24032        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24033                 + 4.0d0 * hawk    * rij_shift**5.0d0
24034 !c! dF/dom1
24035        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24036 !c! dF/dom2
24037        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24038        eom1  =    dGCLdOM1+dGCLdOM2
24039        eom2  =    0.0
24040
24041           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24042 !          fac=0.0
24043           gg(1) =  fac*xj*rij
24044           gg(2) =  fac*yj*rij
24045           gg(3) =  fac*zj*rij
24046          do k=1,3
24047          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24048          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24049          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24050          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24051          gg(k)=0.0
24052          enddo
24053
24054       DO k = 1, 3
24055         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24056         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24057         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24058         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24059 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24060         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24061 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24062         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24063                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24064         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24065                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24066         enddo
24067        epeppho=epeppho+evdwij+Fcav+ECL
24068 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24069        enddo
24070        enddo
24071       end subroutine eprot_pep_phosphate
24072       end module energy