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       call ebond_nucl(estr_nucl)
 609       call ebend_nucl(ebe_nucl)
 610       call etor_nucl(etors_nucl)
 611       call esb_gb(evdwsb,eelsb)
 612       call epp_nucl_sub(evdwpp,eespp)
 613       call epsb(evdwpsb,eelpsb)
 614       call esb(esbloc)
 615       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 616       call ecatcat(ecationcation)
 617       call ecat_prot(ecation_prot)
 618       call eprot_sc_base(escbase)
 619       call epep_sc_base(epepbase)
 620       call eprot_sc_phosphate(escpho)
 621       call eprot_pep_phosphate(epeppho)
 622 !      call ecatcat(ecationcation)
 623 !      print *,"after ebend", ebe_nucl
 624 #ifdef TIMING
 625       time_enecalc=time_enecalc+MPI_Wtime()-time00
 626 #endif
 627 !      print *,"Processor",myrank," computed Uconstr"
 628 #ifdef TIMING
 629       time00=MPI_Wtime()
 630 #endif
 631 !
 632 ! Sum the energies
 633 !
 634       energia(1)=evdw
 635 #ifdef SCP14
 636       energia(2)=evdw2-evdw2_14
 637       energia(18)=evdw2_14
 638 #else
 639       energia(2)=evdw2
 640       energia(18)=0.0d0
 641 #endif
 642 #ifdef SPLITELE
 643       energia(3)=ees
 644       energia(16)=evdw1
 645 #else
 646       energia(3)=ees+evdw1
 647       energia(16)=0.0d0
 648 #endif
 649       energia(4)=ecorr
 650       energia(5)=ecorr5
 651       energia(6)=ecorr6
 652       energia(7)=eel_loc
 653       energia(8)=eello_turn3
 654       energia(9)=eello_turn4
 655       energia(10)=eturn6
 656       energia(11)=ebe
 657       energia(12)=escloc
 658       energia(13)=etors
 659       energia(14)=etors_d
 660       energia(15)=ehpb
 661       energia(19)=edihcnstr
 662       energia(17)=estr
 663       energia(20)=Uconst+Uconst_back
 664       energia(21)=esccor
 665       energia(22)=eliptran
 666       energia(23)=Eafmforce
 667       energia(24)=ethetacnstr
 668       energia(25)=etube
 669 !---------------------------------------------------------------
 670       energia(26)=evdwpp
 671       energia(27)=eespp
 672       energia(28)=evdwpsb
 673       energia(29)=eelpsb
 674       energia(30)=evdwsb
 675       energia(31)=eelsb
 676       energia(32)=estr_nucl
 677       energia(33)=ebe_nucl
 678       energia(34)=esbloc
 679       energia(35)=etors_nucl
 680       energia(36)=etors_d_nucl
 681       energia(37)=ecorr_nucl
 682       energia(38)=ecorr3_nucl
 683 !----------------------------------------------------------------------
 684 !    Here are the energies showed per procesor if the are more processors
 685 !    per molecule then we sum it up in sum_energy subroutine
 686 !      print *," Processor",myrank," calls SUM_ENERGY"
 687       energia(41)=ecation_prot
 688       energia(42)=ecationcation
 689       energia(46)=escbase
 690       energia(47)=epepbase
 691       energia(48)=escpho
 692       energia(49)=epeppho
 693       call sum_energy(energia,.true.)
 694       if (dyn_ss) call dyn_set_nss
 695 !      print *," Processor",myrank," left SUM_ENERGY"
 696 #ifdef TIMING
 697       time_sumene=time_sumene+MPI_Wtime()-time00
 698 #endif
 699 !el        call enerprint(energia)
 700 !elwrite(iout,*)"finish etotal"
 701       return
 702       end subroutine etotal
 703 !-----------------------------------------------------------------------------
 704       subroutine sum_energy(energia,reduce)
 705 !      implicit real*8 (a-h,o-z)
 706 !      include 'DIMENSIONS'
 707 #ifndef ISNAN
 708       external proc_proc
 709 #ifdef WINPGI
 710 !MS$ATTRIBUTES C ::  proc_proc
 711 #endif
 712 #endif
 713 #ifdef MPI
 714       include "mpif.h"
 715 #endif
 716 !      include 'COMMON.SETUP'
 717 !      include 'COMMON.IOUNITS'
 718       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 719 !      include 'COMMON.FFIELD'
 720 !      include 'COMMON.DERIV'
 721 !      include 'COMMON.INTERACT'
 722 !      include 'COMMON.SBRIDGE'
 723 !      include 'COMMON.CHAIN'
 724 !      include 'COMMON.VAR'
 725 !      include 'COMMON.CONTROL'
 726 !      include 'COMMON.TIME1'
 727       logical :: reduce
 728       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 729       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 730       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 731         eliptran,etube, Eafmforce,ethetacnstr
 732       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 733                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 734                       ecorr3_nucl
 735       real(kind=8) :: ecation_prot,ecationcation
 736       real(kind=8) :: escbase,epepbase,escpho,epeppho
 737       integer :: i
 738 #ifdef MPI
 739       integer :: ierr
 740       real(kind=8) :: time00
 741       if (nfgtasks.gt.1 .and. reduce) then
 742
 743 #ifdef DEBUG
 744         write (iout,*) "energies before REDUCE"
 745         call enerprint(energia)
 746         call flush(iout)
 747 #endif
 748         do i=0,n_ene
 749           enebuff(i)=energia(i)
 750         enddo
 751         time00=MPI_Wtime()
 752         call MPI_Barrier(FG_COMM,IERR)
 753         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 754         time00=MPI_Wtime()
 755         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 756           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 757 #ifdef DEBUG
 758         write (iout,*) "energies after REDUCE"
 759         call enerprint(energia)
 760         call flush(iout)
 761 #endif
 762         time_Reduce=time_Reduce+MPI_Wtime()-time00
 763       endif
 764       if (fg_rank.eq.0) then
 765 #endif
 766       evdw=energia(1)
 767 #ifdef SCP14
 768       evdw2=energia(2)+energia(18)
 769       evdw2_14=energia(18)
 770 #else
 771       evdw2=energia(2)
 772 #endif
 773 #ifdef SPLITELE
 774       ees=energia(3)
 775       evdw1=energia(16)
 776 #else
 777       ees=energia(3)
 778       evdw1=0.0d0
 779 #endif
 780       ecorr=energia(4)
 781       ecorr5=energia(5)
 782       ecorr6=energia(6)
 783       eel_loc=energia(7)
 784       eello_turn3=energia(8)
 785       eello_turn4=energia(9)
 786       eturn6=energia(10)
 787       ebe=energia(11)
 788       escloc=energia(12)
 789       etors=energia(13)
 790       etors_d=energia(14)
 791       ehpb=energia(15)
 792       edihcnstr=energia(19)
 793       estr=energia(17)
 794       Uconst=energia(20)
 795       esccor=energia(21)
 796       eliptran=energia(22)
 797       Eafmforce=energia(23)
 798       ethetacnstr=energia(24)
 799       etube=energia(25)
 800       evdwpp=energia(26)
 801       eespp=energia(27)
 802       evdwpsb=energia(28)
 803       eelpsb=energia(29)
 804       evdwsb=energia(30)
 805       eelsb=energia(31)
 806       estr_nucl=energia(32)
 807       ebe_nucl=energia(33)
 808       esbloc=energia(34)
 809       etors_nucl=energia(35)
 810       etors_d_nucl=energia(36)
 811       ecorr_nucl=energia(37)
 812       ecorr3_nucl=energia(38)
 813       ecation_prot=energia(41)
 814       ecationcation=energia(42)
 815       escbase=energia(46)
 816       epepbase=energia(47)
 817       escpho=energia(48)
 818       epeppho=energia(49)
 819 !      energia(41)=ecation_prot
 820 !      energia(42)=ecationcation
 821
 822
 823 #ifdef SPLITELE
 824       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 825        +wang*ebe+wtor*etors+wscloc*escloc &
 826        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 827        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 828        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 829        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 830        +Eafmforce+ethetacnstr  &
 831        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 832        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 833        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 834        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 835        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 836        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 837 #else
 838       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 839        +wang*ebe+wtor*etors+wscloc*escloc &
 840        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 841        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 842        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 843        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 844        +Eafmforce+ethetacnstr &
 845        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 846        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 847        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 848        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 849        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 850        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 851 #endif
 852       energia(0)=etot
 853 ! detecting NaNQ
 854 #ifdef ISNAN
 855 #ifdef AIX
 856       if (isnan(etot).ne.0) energia(0)=1.0d+99
 857 #else
 858       if (isnan(etot)) energia(0)=1.0d+99
 859 #endif
 860 #else
 861       i=0
 862 #ifdef WINPGI
 863       idumm=proc_proc(etot,i)
 864 #else
 865       call proc_proc(etot,i)
 866 #endif
 867       if(i.eq.1)energia(0)=1.0d+99
 868 #endif
 869 #ifdef MPI
 870       endif
 871 #endif
 872 !      call enerprint(energia)
 873       call flush(iout)
 874       return
 875       end subroutine sum_energy
 876 !-----------------------------------------------------------------------------
 877       subroutine rescale_weights(t_bath)
 878 !      implicit real*8 (a-h,o-z)
 879 #ifdef MPI
 880       include 'mpif.h'
 881 #endif
 882 !      include 'DIMENSIONS'
 883 !      include 'COMMON.IOUNITS'
 884 !      include 'COMMON.FFIELD'
 885 !      include 'COMMON.SBRIDGE'
 886       real(kind=8) :: kfac=2.4d0
 887       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 888 !el local variables
 889       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 890       real(kind=8) :: T0=3.0d2
 891       integer :: ierror
 892 !      facT=temp0/t_bath
 893 !      facT=2*temp0/(t_bath+temp0)
 894       if (rescale_mode.eq.0) then
 895         facT(1)=1.0d0
 896         facT(2)=1.0d0
 897         facT(3)=1.0d0
 898         facT(4)=1.0d0
 899         facT(5)=1.0d0
 900         facT(6)=1.0d0
 901       else if (rescale_mode.eq.1) then
 902         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 903         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 904         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 905         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 906         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 907 #ifdef WHAM_RUN
 908 !#if defined(WHAM_RUN) || defined(CLUSTER)
 909 #if defined(FUNCTH)
 910 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 911         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 912 #elif defined(FUNCT)
 913         facT(6)=t_bath/T0
 914 #else
 915         facT(6)=1.0d0
 916 #endif
 917 #endif
 918       else if (rescale_mode.eq.2) then
 919         x=t_bath/temp0
 920         x2=x*x
 921         x3=x2*x
 922         x4=x3*x
 923         x5=x4*x
 924         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 925         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 926         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 927         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 928         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 929 #ifdef WHAM_RUN
 930 !#if defined(WHAM_RUN) || defined(CLUSTER)
 931 #if defined(FUNCTH)
 932         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 933 #elif defined(FUNCT)
 934         facT(6)=t_bath/T0
 935 #else
 936         facT(6)=1.0d0
 937 #endif
 938 #endif
 939       else
 940         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 941         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 942 #ifdef MPI
 943        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 944 #endif
 945        stop 555
 946       endif
 947       welec=weights(3)*fact(1)
 948       wcorr=weights(4)*fact(3)
 949       wcorr5=weights(5)*fact(4)
 950       wcorr6=weights(6)*fact(5)
 951       wel_loc=weights(7)*fact(2)
 952       wturn3=weights(8)*fact(2)
 953       wturn4=weights(9)*fact(3)
 954       wturn6=weights(10)*fact(5)
 955       wtor=weights(13)*fact(1)
 956       wtor_d=weights(14)*fact(2)
 957       wsccor=weights(21)*fact(1)
 958
 959       return
 960       end subroutine rescale_weights
 961 !-----------------------------------------------------------------------------
 962       subroutine enerprint(energia)
 963 !      implicit real*8 (a-h,o-z)
 964 !      include 'DIMENSIONS'
 965 !      include 'COMMON.IOUNITS'
 966 !      include 'COMMON.FFIELD'
 967 !      include 'COMMON.SBRIDGE'
 968 !      include 'COMMON.MD'
 969       real(kind=8) :: energia(0:n_ene)
 970 !el local variables
 971       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
 972       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
 973       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
 974        etube,ethetacnstr,Eafmforce
 975       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 976                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 977                       ecorr3_nucl
 978       real(kind=8) :: ecation_prot,ecationcation
 979       real(kind=8) :: escbase,epepbase,escpho,epeppho
 980
 981       etot=energia(0)
 982       evdw=energia(1)
 983       evdw2=energia(2)
 984 #ifdef SCP14
 985       evdw2=energia(2)+energia(18)
 986 #else
 987       evdw2=energia(2)
 988 #endif
 989       ees=energia(3)
 990 #ifdef SPLITELE
 991       evdw1=energia(16)
 992 #endif
 993       ecorr=energia(4)
 994       ecorr5=energia(5)
 995       ecorr6=energia(6)
 996       eel_loc=energia(7)
 997       eello_turn3=energia(8)
 998       eello_turn4=energia(9)
 999       eello_turn6=energia(10)
1000       ebe=energia(11)
1001       escloc=energia(12)
1002       etors=energia(13)
1003       etors_d=energia(14)
1004       ehpb=energia(15)
1005       edihcnstr=energia(19)
1006       estr=energia(17)
1007       Uconst=energia(20)
1008       esccor=energia(21)
1009       eliptran=energia(22)
1010       Eafmforce=energia(23)
1011       ethetacnstr=energia(24)
1012       etube=energia(25)
1013       evdwpp=energia(26)
1014       eespp=energia(27)
1015       evdwpsb=energia(28)
1016       eelpsb=energia(29)
1017       evdwsb=energia(30)
1018       eelsb=energia(31)
1019       estr_nucl=energia(32)
1020       ebe_nucl=energia(33)
1021       esbloc=energia(34)
1022       etors_nucl=energia(35)
1023       etors_d_nucl=energia(36)
1024       ecorr_nucl=energia(37)
1025       ecorr3_nucl=energia(38)
1026       ecation_prot=energia(41)
1027       ecationcation=energia(42)
1028       escbase=energia(46)
1029       epepbase=energia(47)
1030       escpho=energia(48)
1031       epeppho=energia(49)
1032 #ifdef SPLITELE
1033       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1034         estr,wbond,ebe,wang,&
1035         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1036         ecorr,wcorr,&
1037         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1038         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1039         edihcnstr,ethetacnstr,ebr*nss,&
1040         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1041         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1042         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1043         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1044         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1045         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1046         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1047         etot
1048    10 format (/'Virtual-chain energies:'// &
1049        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1050        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1051        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1052        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1053        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1054        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1055        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1056        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1057        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1058        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1059        ' (SS bridges & dist. cnstr.)'/ &
1060        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1061        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1062        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1063        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1064        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1065        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1066        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1067        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1068        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1069        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1070        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1071        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1072        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1073        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1074        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1075        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1076        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1077        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1078        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1079        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1080        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1081        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1082        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1083        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1084        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1085        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1086        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1087        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1088        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1089        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1090        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1091        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1092        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1093        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1094        'ETOT=  ',1pE16.6,' (total)')
1095 #else
1096       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1097         estr,wbond,ebe,wang,&
1098         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1099         ecorr,wcorr,&
1100         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1101         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1102         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1103         etube,wtube, &
1104         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1105         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1106         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1107         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1108         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1109         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1110         etot
1111    10 format (/'Virtual-chain energies:'// &
1112        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1113        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1114        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1115        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1116        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1117        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1118        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1119        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1120        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1121        ' (SS bridges & dist. cnstr.)'/ &
1122        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1123        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1124        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1125        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1126        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1127        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1128        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1129        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1130        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1131        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1132        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1133        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1134        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1135        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1136        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1137        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1138        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1139        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1140        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1141        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1142        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1143        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1144        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1145        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1146        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1147        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1148        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1149        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1150        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1151        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1152        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1153        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1154        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1155        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1156        'ETOT=  ',1pE16.6,' (total)')
1157 #endif
1158       return
1159       end subroutine enerprint
1160 !-----------------------------------------------------------------------------
1161       subroutine elj(evdw)
1162 !
1163 ! This subroutine calculates the interaction energy of nonbonded side chains
1164 ! assuming the LJ potential of interaction.
1165 !
1166 !      implicit real*8 (a-h,o-z)
1167 !      include 'DIMENSIONS'
1168       real(kind=8),parameter :: accur=1.0d-10
1169 !      include 'COMMON.GEO'
1170 !      include 'COMMON.VAR'
1171 !      include 'COMMON.LOCAL'
1172 !      include 'COMMON.CHAIN'
1173 !      include 'COMMON.DERIV'
1174 !      include 'COMMON.INTERACT'
1175 !      include 'COMMON.TORSION'
1176 !      include 'COMMON.SBRIDGE'
1177 !      include 'COMMON.NAMES'
1178 !      include 'COMMON.IOUNITS'
1179 !      include 'COMMON.CONTACTS'
1180       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1181       integer :: num_conti
1182 !el local variables
1183       integer :: i,itypi,iint,j,itypi1,itypj,k
1184       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1185       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1186       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1187
1188 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1189       evdw=0.0D0
1190 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1191 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1192 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1193 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1194
1195       do i=iatsc_s,iatsc_e
1196         itypi=iabs(itype(i,1))
1197         if (itypi.eq.ntyp1) cycle
1198         itypi1=iabs(itype(i+1,1))
1199         xi=c(1,nres+i)
1200         yi=c(2,nres+i)
1201         zi=c(3,nres+i)
1202 ! Change 12/1/95
1203         num_conti=0
1204 !
1205 ! Calculate SC interaction energy.
1206 !
1207         do iint=1,nint_gr(i)
1208 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1209 !d   &                  'iend=',iend(i,iint)
1210           do j=istart(i,iint),iend(i,iint)
1211             itypj=iabs(itype(j,1))
1212             if (itypj.eq.ntyp1) cycle
1213             xj=c(1,nres+j)-xi
1214             yj=c(2,nres+j)-yi
1215             zj=c(3,nres+j)-zi
1216 ! Change 12/1/95 to calculate four-body interactions
1217             rij=xj*xj+yj*yj+zj*zj
1218             rrij=1.0D0/rij
1219 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1220             eps0ij=eps(itypi,itypj)
1221             fac=rrij**expon2
1222             e1=fac*fac*aa_aq(itypi,itypj)
1223             e2=fac*bb_aq(itypi,itypj)
1224             evdwij=e1+e2
1225 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1226 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1227 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1228 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1229 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1230 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1231             evdw=evdw+evdwij
1232 !
1233 ! Calculate the components of the gradient in DC and X
1234 !
1235             fac=-rrij*(e1+evdwij)
1236             gg(1)=xj*fac
1237             gg(2)=yj*fac
1238             gg(3)=zj*fac
1239             do k=1,3
1240               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1241               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1242               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1243               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1244             enddo
1245 !grad            do k=i,j-1
1246 !grad              do l=1,3
1247 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1248 !grad              enddo
1249 !grad            enddo
1250 !
1251 ! 12/1/95, revised on 5/20/97
1252 !
1253 ! Calculate the contact function. The ith column of the array JCONT will
1254 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1255 ! greater than I). The arrays FACONT and GACONT will contain the values of
1256 ! the contact function and its derivative.
1257 !
1258 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1259 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1260 ! Uncomment next line, if the correlation interactions are contact function only
1261             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1262               rij=dsqrt(rij)
1263               sigij=sigma(itypi,itypj)
1264               r0ij=rs0(itypi,itypj)
1265 !
1266 ! Check whether the SC's are not too far to make a contact.
1267 !
1268               rcut=1.5d0*r0ij
1269               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1270 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1271 !
1272               if (fcont.gt.0.0D0) then
1273 ! If the SC-SC distance if close to sigma, apply spline.
1274 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1275 !Adam &             fcont1,fprimcont1)
1276 !Adam           fcont1=1.0d0-fcont1
1277 !Adam           if (fcont1.gt.0.0d0) then
1278 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1279 !Adam             fcont=fcont*fcont1
1280 !Adam           endif
1281 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1282 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1283 !ga             do k=1,3
1284 !ga               gg(k)=gg(k)*eps0ij
1285 !ga             enddo
1286 !ga             eps0ij=-evdwij*eps0ij
1287 ! Uncomment for AL's type of SC correlation interactions.
1288 !adam           eps0ij=-evdwij
1289                 num_conti=num_conti+1
1290                 jcont(num_conti,i)=j
1291                 facont(num_conti,i)=fcont*eps0ij
1292                 fprimcont=eps0ij*fprimcont/rij
1293                 fcont=expon*fcont
1294 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1295 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1296 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1297 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1298                 gacont(1,num_conti,i)=-fprimcont*xj
1299                 gacont(2,num_conti,i)=-fprimcont*yj
1300                 gacont(3,num_conti,i)=-fprimcont*zj
1301 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1302 !d              write (iout,'(2i3,3f10.5)')
1303 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1304               endif
1305             endif
1306           enddo      ! j
1307         enddo        ! iint
1308 ! Change 12/1/95
1309         num_cont(i)=num_conti
1310       enddo          ! i
1311       do i=1,nct
1312         do j=1,3
1313           gvdwc(j,i)=expon*gvdwc(j,i)
1314           gvdwx(j,i)=expon*gvdwx(j,i)
1315         enddo
1316       enddo
1317 !******************************************************************************
1318 !
1319 !                              N O T E !!!
1320 !
1321 ! To save time, the factor of EXPON has been extracted from ALL components
1322 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1323 ! use!
1324 !
1325 !******************************************************************************
1326       return
1327       end subroutine elj
1328 !-----------------------------------------------------------------------------
1329       subroutine eljk(evdw)
1330 !
1331 ! This subroutine calculates the interaction energy of nonbonded side chains
1332 ! assuming the LJK potential of interaction.
1333 !
1334 !      implicit real*8 (a-h,o-z)
1335 !      include 'DIMENSIONS'
1336 !      include 'COMMON.GEO'
1337 !      include 'COMMON.VAR'
1338 !      include 'COMMON.LOCAL'
1339 !      include 'COMMON.CHAIN'
1340 !      include 'COMMON.DERIV'
1341 !      include 'COMMON.INTERACT'
1342 !      include 'COMMON.IOUNITS'
1343 !      include 'COMMON.NAMES'
1344       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1345       logical :: scheck
1346 !el local variables
1347       integer :: i,iint,j,itypi,itypi1,k,itypj
1348       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1349       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1350
1351 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1352       evdw=0.0D0
1353       do i=iatsc_s,iatsc_e
1354         itypi=iabs(itype(i,1))
1355         if (itypi.eq.ntyp1) cycle
1356         itypi1=iabs(itype(i+1,1))
1357         xi=c(1,nres+i)
1358         yi=c(2,nres+i)
1359         zi=c(3,nres+i)
1360 !
1361 ! Calculate SC interaction energy.
1362 !
1363         do iint=1,nint_gr(i)
1364           do j=istart(i,iint),iend(i,iint)
1365             itypj=iabs(itype(j,1))
1366             if (itypj.eq.ntyp1) cycle
1367             xj=c(1,nres+j)-xi
1368             yj=c(2,nres+j)-yi
1369             zj=c(3,nres+j)-zi
1370             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1371             fac_augm=rrij**expon
1372             e_augm=augm(itypi,itypj)*fac_augm
1373             r_inv_ij=dsqrt(rrij)
1374             rij=1.0D0/r_inv_ij
1375             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1376             fac=r_shift_inv**expon
1377             e1=fac*fac*aa_aq(itypi,itypj)
1378             e2=fac*bb_aq(itypi,itypj)
1379             evdwij=e_augm+e1+e2
1380 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1381 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1382 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1383 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1384 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1385 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1386 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1387             evdw=evdw+evdwij
1388 !
1389 ! Calculate the components of the gradient in DC and X
1390 !
1391             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1392             gg(1)=xj*fac
1393             gg(2)=yj*fac
1394             gg(3)=zj*fac
1395             do k=1,3
1396               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1397               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1398               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1399               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1400             enddo
1401 !grad            do k=i,j-1
1402 !grad              do l=1,3
1403 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1404 !grad              enddo
1405 !grad            enddo
1406           enddo      ! j
1407         enddo        ! iint
1408       enddo          ! i
1409       do i=1,nct
1410         do j=1,3
1411           gvdwc(j,i)=expon*gvdwc(j,i)
1412           gvdwx(j,i)=expon*gvdwx(j,i)
1413         enddo
1414       enddo
1415       return
1416       end subroutine eljk
1417 !-----------------------------------------------------------------------------
1418       subroutine ebp(evdw)
1419 !
1420 ! This subroutine calculates the interaction energy of nonbonded side chains
1421 ! assuming the Berne-Pechukas potential of interaction.
1422 !
1423       use comm_srutu
1424       use calc_data
1425 !      implicit real*8 (a-h,o-z)
1426 !      include 'DIMENSIONS'
1427 !      include 'COMMON.GEO'
1428 !      include 'COMMON.VAR'
1429 !      include 'COMMON.LOCAL'
1430 !      include 'COMMON.CHAIN'
1431 !      include 'COMMON.DERIV'
1432 !      include 'COMMON.NAMES'
1433 !      include 'COMMON.INTERACT'
1434 !      include 'COMMON.IOUNITS'
1435 !      include 'COMMON.CALC'
1436       use comm_srutu
1437 !el      integer :: icall
1438 !el      common /srutu/ icall
1439 !     double precision rrsave(maxdim)
1440       logical :: lprn
1441 !el local variables
1442       integer :: iint,itypi,itypi1,itypj
1443       real(kind=8) :: rrij,xi,yi,zi
1444       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1445
1446 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1447       evdw=0.0D0
1448 !     if (icall.eq.0) then
1449 !       lprn=.true.
1450 !     else
1451         lprn=.false.
1452 !     endif
1453 !el      ind=0
1454       do i=iatsc_s,iatsc_e
1455         itypi=iabs(itype(i,1))
1456         if (itypi.eq.ntyp1) cycle
1457         itypi1=iabs(itype(i+1,1))
1458         xi=c(1,nres+i)
1459         yi=c(2,nres+i)
1460         zi=c(3,nres+i)
1461         dxi=dc_norm(1,nres+i)
1462         dyi=dc_norm(2,nres+i)
1463         dzi=dc_norm(3,nres+i)
1464 !        dsci_inv=dsc_inv(itypi)
1465         dsci_inv=vbld_inv(i+nres)
1466 !
1467 ! Calculate SC interaction energy.
1468 !
1469         do iint=1,nint_gr(i)
1470           do j=istart(i,iint),iend(i,iint)
1471 !el            ind=ind+1
1472             itypj=iabs(itype(j,1))
1473             if (itypj.eq.ntyp1) cycle
1474 !            dscj_inv=dsc_inv(itypj)
1475             dscj_inv=vbld_inv(j+nres)
1476             chi1=chi(itypi,itypj)
1477             chi2=chi(itypj,itypi)
1478             chi12=chi1*chi2
1479             chip1=chip(itypi)
1480             chip2=chip(itypj)
1481             chip12=chip1*chip2
1482             alf1=alp(itypi)
1483             alf2=alp(itypj)
1484             alf12=0.5D0*(alf1+alf2)
1485 ! For diagnostics only!!!
1486 !           chi1=0.0D0
1487 !           chi2=0.0D0
1488 !           chi12=0.0D0
1489 !           chip1=0.0D0
1490 !           chip2=0.0D0
1491 !           chip12=0.0D0
1492 !           alf1=0.0D0
1493 !           alf2=0.0D0
1494 !           alf12=0.0D0
1495             xj=c(1,nres+j)-xi
1496             yj=c(2,nres+j)-yi
1497             zj=c(3,nres+j)-zi
1498             dxj=dc_norm(1,nres+j)
1499             dyj=dc_norm(2,nres+j)
1500             dzj=dc_norm(3,nres+j)
1501             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1502 !d          if (icall.eq.0) then
1503 !d            rrsave(ind)=rrij
1504 !d          else
1505 !d            rrij=rrsave(ind)
1506 !d          endif
1507             rij=dsqrt(rrij)
1508 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1509             call sc_angular
1510 ! Calculate whole angle-dependent part of epsilon and contributions
1511 ! to its derivatives
1512             fac=(rrij*sigsq)**expon2
1513             e1=fac*fac*aa_aq(itypi,itypj)
1514             e2=fac*bb_aq(itypi,itypj)
1515             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1516             eps2der=evdwij*eps3rt
1517             eps3der=evdwij*eps2rt
1518             evdwij=evdwij*eps2rt*eps3rt
1519             evdw=evdw+evdwij
1520             if (lprn) then
1521             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1522             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1523 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1524 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1525 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1526 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1527 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1528 !d     &        evdwij
1529             endif
1530 ! Calculate gradient components.
1531             e1=e1*eps1*eps2rt**2*eps3rt**2
1532             fac=-expon*(e1+evdwij)
1533             sigder=fac/sigsq
1534             fac=rrij*fac
1535 ! Calculate radial part of the gradient
1536             gg(1)=xj*fac
1537             gg(2)=yj*fac
1538             gg(3)=zj*fac
1539 ! Calculate the angular part of the gradient and sum add the contributions
1540 ! to the appropriate components of the Cartesian gradient.
1541             call sc_grad
1542           enddo      ! j
1543         enddo        ! iint
1544       enddo          ! i
1545 !     stop
1546       return
1547       end subroutine ebp
1548 !-----------------------------------------------------------------------------
1549       subroutine egb(evdw)
1550 !
1551 ! This subroutine calculates the interaction energy of nonbonded side chains
1552 ! assuming the Gay-Berne potential of interaction.
1553 !
1554       use calc_data
1555 !      implicit real*8 (a-h,o-z)
1556 !      include 'DIMENSIONS'
1557 !      include 'COMMON.GEO'
1558 !      include 'COMMON.VAR'
1559 !      include 'COMMON.LOCAL'
1560 !      include 'COMMON.CHAIN'
1561 !      include 'COMMON.DERIV'
1562 !      include 'COMMON.NAMES'
1563 !      include 'COMMON.INTERACT'
1564 !      include 'COMMON.IOUNITS'
1565 !      include 'COMMON.CALC'
1566 !      include 'COMMON.CONTROL'
1567 !      include 'COMMON.SBRIDGE'
1568       logical :: lprn
1569 !el local variables
1570       integer :: iint,itypi,itypi1,itypj,subchap
1571       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1572       real(kind=8) :: evdw,sig0ij
1573       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1574                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1575                     sslipi,sslipj,faclip
1576       integer :: ii
1577       real(kind=8) :: fracinbuf
1578
1579 !cccc      energy_dec=.false.
1580 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1581       evdw=0.0D0
1582       lprn=.false.
1583 !     if (icall.eq.0) lprn=.false.
1584 !el      ind=0
1585       do i=iatsc_s,iatsc_e
1586 !C        print *,"I am in EVDW",i
1587         itypi=iabs(itype(i,1))
1588 !        if (i.ne.47) cycle
1589         if (itypi.eq.ntyp1) cycle
1590         itypi1=iabs(itype(i+1,1))
1591         xi=c(1,nres+i)
1592         yi=c(2,nres+i)
1593         zi=c(3,nres+i)
1594           xi=dmod(xi,boxxsize)
1595           if (xi.lt.0) xi=xi+boxxsize
1596           yi=dmod(yi,boxysize)
1597           if (yi.lt.0) yi=yi+boxysize
1598           zi=dmod(zi,boxzsize)
1599           if (zi.lt.0) zi=zi+boxzsize
1600
1601        if ((zi.gt.bordlipbot)  &
1602         .and.(zi.lt.bordliptop)) then
1603 !C the energy transfer exist
1604         if (zi.lt.buflipbot) then
1605 !C what fraction I am in
1606          fracinbuf=1.0d0-  &
1607               ((zi-bordlipbot)/lipbufthick)
1608 !C lipbufthick is thickenes of lipid buffore
1609          sslipi=sscalelip(fracinbuf)
1610          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1611         elseif (zi.gt.bufliptop) then
1612          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1613          sslipi=sscalelip(fracinbuf)
1614          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1615         else
1616          sslipi=1.0d0
1617          ssgradlipi=0.0
1618         endif
1619        else
1620          sslipi=0.0d0
1621          ssgradlipi=0.0
1622        endif
1623 !       print *, sslipi,ssgradlipi
1624         dxi=dc_norm(1,nres+i)
1625         dyi=dc_norm(2,nres+i)
1626         dzi=dc_norm(3,nres+i)
1627 !        dsci_inv=dsc_inv(itypi)
1628         dsci_inv=vbld_inv(i+nres)
1629 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1630 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1631 !
1632 ! Calculate SC interaction energy.
1633 !
1634         do iint=1,nint_gr(i)
1635           do j=istart(i,iint),iend(i,iint)
1636             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1637               call dyn_ssbond_ene(i,j,evdwij)
1638               evdw=evdw+evdwij
1639               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1640                               'evdw',i,j,evdwij,' ss'
1641 !              if (energy_dec) write (iout,*) &
1642 !                              'evdw',i,j,evdwij,' ss'
1643              do k=j+1,iend(i,iint)
1644 !C search over all next residues
1645               if (dyn_ss_mask(k)) then
1646 !C check if they are cysteins
1647 !C              write(iout,*) 'k=',k
1648
1649 !c              write(iout,*) "PRZED TRI", evdwij
1650 !               evdwij_przed_tri=evdwij
1651               call triple_ssbond_ene(i,j,k,evdwij)
1652 !c               if(evdwij_przed_tri.ne.evdwij) then
1653 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1654 !c               endif
1655
1656 !c              write(iout,*) "PO TRI", evdwij
1657 !C call the energy function that removes the artifical triple disulfide
1658 !C bond the soubroutine is located in ssMD.F
1659               evdw=evdw+evdwij
1660               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1661                             'evdw',i,j,evdwij,'tss'
1662               endif!dyn_ss_mask(k)
1663              enddo! k
1664             ELSE
1665 !el            ind=ind+1
1666             itypj=iabs(itype(j,1))
1667             if (itypj.eq.ntyp1) cycle
1668 !             if (j.ne.78) cycle
1669 !            dscj_inv=dsc_inv(itypj)
1670             dscj_inv=vbld_inv(j+nres)
1671 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1672 !              1.0d0/vbld(j+nres) !d
1673 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1674             sig0ij=sigma(itypi,itypj)
1675             chi1=chi(itypi,itypj)
1676             chi2=chi(itypj,itypi)
1677             chi12=chi1*chi2
1678             chip1=chip(itypi)
1679             chip2=chip(itypj)
1680             chip12=chip1*chip2
1681             alf1=alp(itypi)
1682             alf2=alp(itypj)
1683             alf12=0.5D0*(alf1+alf2)
1684 ! For diagnostics only!!!
1685 !           chi1=0.0D0
1686 !           chi2=0.0D0
1687 !           chi12=0.0D0
1688 !           chip1=0.0D0
1689 !           chip2=0.0D0
1690 !           chip12=0.0D0
1691 !           alf1=0.0D0
1692 !           alf2=0.0D0
1693 !           alf12=0.0D0
1694            xj=c(1,nres+j)
1695            yj=c(2,nres+j)
1696            zj=c(3,nres+j)
1697           xj=dmod(xj,boxxsize)
1698           if (xj.lt.0) xj=xj+boxxsize
1699           yj=dmod(yj,boxysize)
1700           if (yj.lt.0) yj=yj+boxysize
1701           zj=dmod(zj,boxzsize)
1702           if (zj.lt.0) zj=zj+boxzsize
1703 !          print *,"tu",xi,yi,zi,xj,yj,zj
1704 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1705 ! this fragment set correct epsilon for lipid phase
1706        if ((zj.gt.bordlipbot)  &
1707        .and.(zj.lt.bordliptop)) then
1708 !C the energy transfer exist
1709         if (zj.lt.buflipbot) then
1710 !C what fraction I am in
1711          fracinbuf=1.0d0-     &
1712              ((zj-bordlipbot)/lipbufthick)
1713 !C lipbufthick is thickenes of lipid buffore
1714          sslipj=sscalelip(fracinbuf)
1715          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1716         elseif (zj.gt.bufliptop) then
1717          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1718          sslipj=sscalelip(fracinbuf)
1719          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1720         else
1721          sslipj=1.0d0
1722          ssgradlipj=0.0
1723         endif
1724        else
1725          sslipj=0.0d0
1726          ssgradlipj=0.0
1727        endif
1728       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1729        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1730       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1731        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1732 !------------------------------------------------
1733       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1734       xj_safe=xj
1735       yj_safe=yj
1736       zj_safe=zj
1737       subchap=0
1738       do xshift=-1,1
1739       do yshift=-1,1
1740       do zshift=-1,1
1741           xj=xj_safe+xshift*boxxsize
1742           yj=yj_safe+yshift*boxysize
1743           zj=zj_safe+zshift*boxzsize
1744           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1745           if(dist_temp.lt.dist_init) then
1746             dist_init=dist_temp
1747             xj_temp=xj
1748             yj_temp=yj
1749             zj_temp=zj
1750             subchap=1
1751           endif
1752        enddo
1753        enddo
1754        enddo
1755        if (subchap.eq.1) then
1756           xj=xj_temp-xi
1757           yj=yj_temp-yi
1758           zj=zj_temp-zi
1759        else
1760           xj=xj_safe-xi
1761           yj=yj_safe-yi
1762           zj=zj_safe-zi
1763        endif
1764             dxj=dc_norm(1,nres+j)
1765             dyj=dc_norm(2,nres+j)
1766             dzj=dc_norm(3,nres+j)
1767 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1768 !            write (iout,*) "j",j," dc_norm",& !d
1769 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1770 !          write(iout,*)"rrij ",rrij
1771 !          write(iout,*)"xj yj zj ", xj, yj, zj
1772 !          write(iout,*)"xi yi zi ", xi, yi, zi
1773 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1774             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1775             rij=dsqrt(rrij)
1776             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1777             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1778 !            print *,sss_ele_cut,sss_ele_grad,&
1779 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1780             if (sss_ele_cut.le.0.0) cycle
1781 ! Calculate angle-dependent terms of energy and contributions to their
1782 ! derivatives.
1783             call sc_angular
1784             sigsq=1.0D0/sigsq
1785             sig=sig0ij*dsqrt(sigsq)
1786             rij_shift=1.0D0/rij-sig+sig0ij
1787 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1788 !            "sig0ij",sig0ij
1789 ! for diagnostics; uncomment
1790 !            rij_shift=1.2*sig0ij
1791 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1792             if (rij_shift.le.0.0D0) then
1793               evdw=1.0D20
1794 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1795 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1796 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1797               return
1798             endif
1799             sigder=-sig*sigsq
1800 !---------------------------------------------------------------
1801             rij_shift=1.0D0/rij_shift
1802             fac=rij_shift**expon
1803             faclip=fac
1804             e1=fac*fac*aa!(itypi,itypj)
1805             e2=fac*bb!(itypi,itypj)
1806             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1807             eps2der=evdwij*eps3rt
1808             eps3der=evdwij*eps2rt
1809 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1810 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1811 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1812             evdwij=evdwij*eps2rt*eps3rt
1813             evdw=evdw+evdwij*sss_ele_cut
1814             if (lprn) then
1815             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1816             epsi=bb**2/aa!(itypi,itypj)
1817             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1818               restyp(itypi,1),i,restyp(itypj,1),j, &
1819               epsi,sigm,chi1,chi2,chip1,chip2, &
1820               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1821               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1822               evdwij
1823             endif
1824
1825             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1826                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1827 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1828 !            if (energy_dec) write (iout,*) &
1829 !                             'evdw',i,j,evdwij
1830 !                       print *,"ZALAMKA", evdw
1831
1832 ! Calculate gradient components.
1833             e1=e1*eps1*eps2rt**2*eps3rt**2
1834             fac=-expon*(e1+evdwij)*rij_shift
1835             sigder=fac*sigder
1836             fac=rij*fac
1837 !            print *,'before fac',fac,rij,evdwij
1838             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1839             /sigma(itypi,itypj)*rij
1840 !            print *,'grad part scale',fac,   &
1841 !             evdwij*sss_ele_grad/sss_ele_cut &
1842 !            /sigma(itypi,itypj)*rij
1843 !            fac=0.0d0
1844 ! Calculate the radial part of the gradient
1845             gg(1)=xj*fac
1846             gg(2)=yj*fac
1847             gg(3)=zj*fac
1848 !C Calculate the radial part of the gradient
1849             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1850        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1851         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1852        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1853             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1854             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1855
1856 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1857 ! Calculate angular part of the gradient.
1858             call sc_grad
1859             ENDIF    ! dyn_ss
1860           enddo      ! j
1861         enddo        ! iint
1862       enddo          ! i
1863 !       print *,"ZALAMKA", evdw
1864 !      write (iout,*) "Number of loop steps in EGB:",ind
1865 !ccc      energy_dec=.false.
1866       return
1867       end subroutine egb
1868 !-----------------------------------------------------------------------------
1869       subroutine egbv(evdw)
1870 !
1871 ! This subroutine calculates the interaction energy of nonbonded side chains
1872 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1873 !
1874       use comm_srutu
1875       use calc_data
1876 !      implicit real*8 (a-h,o-z)
1877 !      include 'DIMENSIONS'
1878 !      include 'COMMON.GEO'
1879 !      include 'COMMON.VAR'
1880 !      include 'COMMON.LOCAL'
1881 !      include 'COMMON.CHAIN'
1882 !      include 'COMMON.DERIV'
1883 !      include 'COMMON.NAMES'
1884 !      include 'COMMON.INTERACT'
1885 !      include 'COMMON.IOUNITS'
1886 !      include 'COMMON.CALC'
1887       use comm_srutu
1888 !el      integer :: icall
1889 !el      common /srutu/ icall
1890       logical :: lprn
1891 !el local variables
1892       integer :: iint,itypi,itypi1,itypj
1893       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1894       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1895
1896 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1897       evdw=0.0D0
1898       lprn=.false.
1899 !     if (icall.eq.0) lprn=.true.
1900 !el      ind=0
1901       do i=iatsc_s,iatsc_e
1902         itypi=iabs(itype(i,1))
1903         if (itypi.eq.ntyp1) cycle
1904         itypi1=iabs(itype(i+1,1))
1905         xi=c(1,nres+i)
1906         yi=c(2,nres+i)
1907         zi=c(3,nres+i)
1908         dxi=dc_norm(1,nres+i)
1909         dyi=dc_norm(2,nres+i)
1910         dzi=dc_norm(3,nres+i)
1911 !        dsci_inv=dsc_inv(itypi)
1912         dsci_inv=vbld_inv(i+nres)
1913 !
1914 ! Calculate SC interaction energy.
1915 !
1916         do iint=1,nint_gr(i)
1917           do j=istart(i,iint),iend(i,iint)
1918 !el            ind=ind+1
1919             itypj=iabs(itype(j,1))
1920             if (itypj.eq.ntyp1) cycle
1921 !            dscj_inv=dsc_inv(itypj)
1922             dscj_inv=vbld_inv(j+nres)
1923             sig0ij=sigma(itypi,itypj)
1924             r0ij=r0(itypi,itypj)
1925             chi1=chi(itypi,itypj)
1926             chi2=chi(itypj,itypi)
1927             chi12=chi1*chi2
1928             chip1=chip(itypi)
1929             chip2=chip(itypj)
1930             chip12=chip1*chip2
1931             alf1=alp(itypi)
1932             alf2=alp(itypj)
1933             alf12=0.5D0*(alf1+alf2)
1934 ! For diagnostics only!!!
1935 !           chi1=0.0D0
1936 !           chi2=0.0D0
1937 !           chi12=0.0D0
1938 !           chip1=0.0D0
1939 !           chip2=0.0D0
1940 !           chip12=0.0D0
1941 !           alf1=0.0D0
1942 !           alf2=0.0D0
1943 !           alf12=0.0D0
1944             xj=c(1,nres+j)-xi
1945             yj=c(2,nres+j)-yi
1946             zj=c(3,nres+j)-zi
1947             dxj=dc_norm(1,nres+j)
1948             dyj=dc_norm(2,nres+j)
1949             dzj=dc_norm(3,nres+j)
1950             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1951             rij=dsqrt(rrij)
1952 ! Calculate angle-dependent terms of energy and contributions to their
1953 ! derivatives.
1954             call sc_angular
1955             sigsq=1.0D0/sigsq
1956             sig=sig0ij*dsqrt(sigsq)
1957             rij_shift=1.0D0/rij-sig+r0ij
1958 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1959             if (rij_shift.le.0.0D0) then
1960               evdw=1.0D20
1961               return
1962             endif
1963             sigder=-sig*sigsq
1964 !---------------------------------------------------------------
1965             rij_shift=1.0D0/rij_shift
1966             fac=rij_shift**expon
1967             e1=fac*fac*aa_aq(itypi,itypj)
1968             e2=fac*bb_aq(itypi,itypj)
1969             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1970             eps2der=evdwij*eps3rt
1971             eps3der=evdwij*eps2rt
1972             fac_augm=rrij**expon
1973             e_augm=augm(itypi,itypj)*fac_augm
1974             evdwij=evdwij*eps2rt*eps3rt
1975             evdw=evdw+evdwij+e_augm
1976             if (lprn) then
1977             sigm=dabs(aa_aq(itypi,itypj)/&
1978             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1979             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1980             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1981               restyp(itypi,1),i,restyp(itypj,1),j,&
1982               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
1983               chi1,chi2,chip1,chip2,&
1984               eps1,eps2rt**2,eps3rt**2,&
1985               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
1986               evdwij+e_augm
1987             endif
1988 ! Calculate gradient components.
1989             e1=e1*eps1*eps2rt**2*eps3rt**2
1990             fac=-expon*(e1+evdwij)*rij_shift
1991             sigder=fac*sigder
1992             fac=rij*fac-2*expon*rrij*e_augm
1993 ! Calculate the radial part of the gradient
1994             gg(1)=xj*fac
1995             gg(2)=yj*fac
1996             gg(3)=zj*fac
1997 ! Calculate angular part of the gradient.
1998             call sc_grad
1999           enddo      ! j
2000         enddo        ! iint
2001       enddo          ! i
2002       end subroutine egbv
2003 !-----------------------------------------------------------------------------
2004 !el      subroutine sc_angular in module geometry
2005 !-----------------------------------------------------------------------------
2006       subroutine e_softsphere(evdw)
2007 !
2008 ! This subroutine calculates the interaction energy of nonbonded side chains
2009 ! assuming the LJ potential of interaction.
2010 !
2011 !      implicit real*8 (a-h,o-z)
2012 !      include 'DIMENSIONS'
2013       real(kind=8),parameter :: accur=1.0d-10
2014 !      include 'COMMON.GEO'
2015 !      include 'COMMON.VAR'
2016 !      include 'COMMON.LOCAL'
2017 !      include 'COMMON.CHAIN'
2018 !      include 'COMMON.DERIV'
2019 !      include 'COMMON.INTERACT'
2020 !      include 'COMMON.TORSION'
2021 !      include 'COMMON.SBRIDGE'
2022 !      include 'COMMON.NAMES'
2023 !      include 'COMMON.IOUNITS'
2024 !      include 'COMMON.CONTACTS'
2025       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2026 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2027 !el local variables
2028       integer :: i,iint,j,itypi,itypi1,itypj,k
2029       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2030       real(kind=8) :: fac
2031
2032       evdw=0.0D0
2033       do i=iatsc_s,iatsc_e
2034         itypi=iabs(itype(i,1))
2035         if (itypi.eq.ntyp1) cycle
2036         itypi1=iabs(itype(i+1,1))
2037         xi=c(1,nres+i)
2038         yi=c(2,nres+i)
2039         zi=c(3,nres+i)
2040 !
2041 ! Calculate SC interaction energy.
2042 !
2043         do iint=1,nint_gr(i)
2044 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2045 !d   &                  'iend=',iend(i,iint)
2046           do j=istart(i,iint),iend(i,iint)
2047             itypj=iabs(itype(j,1))
2048             if (itypj.eq.ntyp1) cycle
2049             xj=c(1,nres+j)-xi
2050             yj=c(2,nres+j)-yi
2051             zj=c(3,nres+j)-zi
2052             rij=xj*xj+yj*yj+zj*zj
2053 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2054             r0ij=r0(itypi,itypj)
2055             r0ijsq=r0ij*r0ij
2056 !            print *,i,j,r0ij,dsqrt(rij)
2057             if (rij.lt.r0ijsq) then
2058               evdwij=0.25d0*(rij-r0ijsq)**2
2059               fac=rij-r0ijsq
2060             else
2061               evdwij=0.0d0
2062               fac=0.0d0
2063             endif
2064             evdw=evdw+evdwij
2065 !
2066 ! Calculate the components of the gradient in DC and X
2067 !
2068             gg(1)=xj*fac
2069             gg(2)=yj*fac
2070             gg(3)=zj*fac
2071             do k=1,3
2072               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2073               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2074               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2075               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2076             enddo
2077 !grad            do k=i,j-1
2078 !grad              do l=1,3
2079 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2080 !grad              enddo
2081 !grad            enddo
2082           enddo ! j
2083         enddo ! iint
2084       enddo ! i
2085       return
2086       end subroutine e_softsphere
2087 !-----------------------------------------------------------------------------
2088       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2089 !
2090 ! Soft-sphere potential of p-p interaction
2091 !
2092 !      implicit real*8 (a-h,o-z)
2093 !      include 'DIMENSIONS'
2094 !      include 'COMMON.CONTROL'
2095 !      include 'COMMON.IOUNITS'
2096 !      include 'COMMON.GEO'
2097 !      include 'COMMON.VAR'
2098 !      include 'COMMON.LOCAL'
2099 !      include 'COMMON.CHAIN'
2100 !      include 'COMMON.DERIV'
2101 !      include 'COMMON.INTERACT'
2102 !      include 'COMMON.CONTACTS'
2103 !      include 'COMMON.TORSION'
2104 !      include 'COMMON.VECTORS'
2105 !      include 'COMMON.FFIELD'
2106       real(kind=8),dimension(3) :: ggg
2107 !d      write(iout,*) 'In EELEC_soft_sphere'
2108 !el local variables
2109       integer :: i,j,k,num_conti,iteli,itelj
2110       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2111       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2112       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2113
2114       ees=0.0D0
2115       evdw1=0.0D0
2116       eel_loc=0.0d0
2117       eello_turn3=0.0d0
2118       eello_turn4=0.0d0
2119 !el      ind=0
2120       do i=iatel_s,iatel_e
2121         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2122         dxi=dc(1,i)
2123         dyi=dc(2,i)
2124         dzi=dc(3,i)
2125         xmedi=c(1,i)+0.5d0*dxi
2126         ymedi=c(2,i)+0.5d0*dyi
2127         zmedi=c(3,i)+0.5d0*dzi
2128         num_conti=0
2129 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2130         do j=ielstart(i),ielend(i)
2131           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2132 !el          ind=ind+1
2133           iteli=itel(i)
2134           itelj=itel(j)
2135           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2136           r0ij=rpp(iteli,itelj)
2137           r0ijsq=r0ij*r0ij
2138           dxj=dc(1,j)
2139           dyj=dc(2,j)
2140           dzj=dc(3,j)
2141           xj=c(1,j)+0.5D0*dxj-xmedi
2142           yj=c(2,j)+0.5D0*dyj-ymedi
2143           zj=c(3,j)+0.5D0*dzj-zmedi
2144           rij=xj*xj+yj*yj+zj*zj
2145           if (rij.lt.r0ijsq) then
2146             evdw1ij=0.25d0*(rij-r0ijsq)**2
2147             fac=rij-r0ijsq
2148           else
2149             evdw1ij=0.0d0
2150             fac=0.0d0
2151           endif
2152           evdw1=evdw1+evdw1ij
2153 !
2154 ! Calculate contributions to the Cartesian gradient.
2155 !
2156           ggg(1)=fac*xj
2157           ggg(2)=fac*yj
2158           ggg(3)=fac*zj
2159           do k=1,3
2160             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2161             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2162           enddo
2163 !
2164 ! Loop over residues i+1 thru j-1.
2165 !
2166 !grad          do k=i+1,j-1
2167 !grad            do l=1,3
2168 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2169 !grad            enddo
2170 !grad          enddo
2171         enddo ! j
2172       enddo   ! i
2173 !grad      do i=nnt,nct-1
2174 !grad        do k=1,3
2175 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2176 !grad        enddo
2177 !grad        do j=i+1,nct-1
2178 !grad          do k=1,3
2179 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2180 !grad          enddo
2181 !grad        enddo
2182 !grad      enddo
2183       return
2184       end subroutine eelec_soft_sphere
2185 !-----------------------------------------------------------------------------
2186       subroutine vec_and_deriv
2187 !      implicit real*8 (a-h,o-z)
2188 !      include 'DIMENSIONS'
2189 #ifdef MPI
2190       include 'mpif.h'
2191 #endif
2192 !      include 'COMMON.IOUNITS'
2193 !      include 'COMMON.GEO'
2194 !      include 'COMMON.VAR'
2195 !      include 'COMMON.LOCAL'
2196 !      include 'COMMON.CHAIN'
2197 !      include 'COMMON.VECTORS'
2198 !      include 'COMMON.SETUP'
2199 !      include 'COMMON.TIME1'
2200       real(kind=8),dimension(3,3,2) :: uyder,uzder
2201       real(kind=8),dimension(2) :: vbld_inv_temp
2202 ! Compute the local reference systems. For reference system (i), the
2203 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2204 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2205 !el local variables
2206       integer :: i,j,k,l
2207       real(kind=8) :: facy,fac,costh
2208
2209 #ifdef PARVEC
2210       do i=ivec_start,ivec_end
2211 #else
2212       do i=1,nres-1
2213 #endif
2214           if (i.eq.nres-1) then
2215 ! Case of the last full residue
2216 ! Compute the Z-axis
2217             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2218             costh=dcos(pi-theta(nres))
2219             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2220             do k=1,3
2221               uz(k,i)=fac*uz(k,i)
2222             enddo
2223 ! Compute the derivatives of uz
2224             uzder(1,1,1)= 0.0d0
2225             uzder(2,1,1)=-dc_norm(3,i-1)
2226             uzder(3,1,1)= dc_norm(2,i-1)
2227             uzder(1,2,1)= dc_norm(3,i-1)
2228             uzder(2,2,1)= 0.0d0
2229             uzder(3,2,1)=-dc_norm(1,i-1)
2230             uzder(1,3,1)=-dc_norm(2,i-1)
2231             uzder(2,3,1)= dc_norm(1,i-1)
2232             uzder(3,3,1)= 0.0d0
2233             uzder(1,1,2)= 0.0d0
2234             uzder(2,1,2)= dc_norm(3,i)
2235             uzder(3,1,2)=-dc_norm(2,i)
2236             uzder(1,2,2)=-dc_norm(3,i)
2237             uzder(2,2,2)= 0.0d0
2238             uzder(3,2,2)= dc_norm(1,i)
2239             uzder(1,3,2)= dc_norm(2,i)
2240             uzder(2,3,2)=-dc_norm(1,i)
2241             uzder(3,3,2)= 0.0d0
2242 ! Compute the Y-axis
2243             facy=fac
2244             do k=1,3
2245               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2246             enddo
2247 ! Compute the derivatives of uy
2248             do j=1,3
2249               do k=1,3
2250                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2251                               -dc_norm(k,i)*dc_norm(j,i-1)
2252                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2253               enddo
2254               uyder(j,j,1)=uyder(j,j,1)-costh
2255               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2256             enddo
2257             do j=1,2
2258               do k=1,3
2259                 do l=1,3
2260                   uygrad(l,k,j,i)=uyder(l,k,j)
2261                   uzgrad(l,k,j,i)=uzder(l,k,j)
2262                 enddo
2263               enddo
2264             enddo
2265             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2266             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2267             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2268             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2269           else
2270 ! Other residues
2271 ! Compute the Z-axis
2272             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2273             costh=dcos(pi-theta(i+2))
2274             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2275             do k=1,3
2276               uz(k,i)=fac*uz(k,i)
2277             enddo
2278 ! Compute the derivatives of uz
2279             uzder(1,1,1)= 0.0d0
2280             uzder(2,1,1)=-dc_norm(3,i+1)
2281             uzder(3,1,1)= dc_norm(2,i+1)
2282             uzder(1,2,1)= dc_norm(3,i+1)
2283             uzder(2,2,1)= 0.0d0
2284             uzder(3,2,1)=-dc_norm(1,i+1)
2285             uzder(1,3,1)=-dc_norm(2,i+1)
2286             uzder(2,3,1)= dc_norm(1,i+1)
2287             uzder(3,3,1)= 0.0d0
2288             uzder(1,1,2)= 0.0d0
2289             uzder(2,1,2)= dc_norm(3,i)
2290             uzder(3,1,2)=-dc_norm(2,i)
2291             uzder(1,2,2)=-dc_norm(3,i)
2292             uzder(2,2,2)= 0.0d0
2293             uzder(3,2,2)= dc_norm(1,i)
2294             uzder(1,3,2)= dc_norm(2,i)
2295             uzder(2,3,2)=-dc_norm(1,i)
2296             uzder(3,3,2)= 0.0d0
2297 ! Compute the Y-axis
2298             facy=fac
2299             do k=1,3
2300               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2301             enddo
2302 ! Compute the derivatives of uy
2303             do j=1,3
2304               do k=1,3
2305                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2306                               -dc_norm(k,i)*dc_norm(j,i+1)
2307                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2308               enddo
2309               uyder(j,j,1)=uyder(j,j,1)-costh
2310               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2311             enddo
2312             do j=1,2
2313               do k=1,3
2314                 do l=1,3
2315                   uygrad(l,k,j,i)=uyder(l,k,j)
2316                   uzgrad(l,k,j,i)=uzder(l,k,j)
2317                 enddo
2318               enddo
2319             enddo
2320             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2321             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2322             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2323             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2324           endif
2325       enddo
2326       do i=1,nres-1
2327         vbld_inv_temp(1)=vbld_inv(i+1)
2328         if (i.lt.nres-1) then
2329           vbld_inv_temp(2)=vbld_inv(i+2)
2330           else
2331           vbld_inv_temp(2)=vbld_inv(i)
2332           endif
2333         do j=1,2
2334           do k=1,3
2335             do l=1,3
2336               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2337               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2338             enddo
2339           enddo
2340         enddo
2341       enddo
2342 #if defined(PARVEC) && defined(MPI)
2343       if (nfgtasks1.gt.1) then
2344         time00=MPI_Wtime()
2345 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2346 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2347 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2348         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2349          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2350          FG_COMM1,IERR)
2351         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2352          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2353          FG_COMM1,IERR)
2354         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2355          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2356          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2357         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2358          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2359          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2360         time_gather=time_gather+MPI_Wtime()-time00
2361       endif
2362 !      if (fg_rank.eq.0) then
2363 !        write (iout,*) "Arrays UY and UZ"
2364 !        do i=1,nres-1
2365 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2366 !     &     (uz(k,i),k=1,3)
2367 !        enddo
2368 !      endif
2369 #endif
2370       return
2371       end subroutine vec_and_deriv
2372 !-----------------------------------------------------------------------------
2373       subroutine check_vecgrad
2374 !      implicit real*8 (a-h,o-z)
2375 !      include 'DIMENSIONS'
2376 !      include 'COMMON.IOUNITS'
2377 !      include 'COMMON.GEO'
2378 !      include 'COMMON.VAR'
2379 !      include 'COMMON.LOCAL'
2380 !      include 'COMMON.CHAIN'
2381 !      include 'COMMON.VECTORS'
2382       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2383       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2384       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2385       real(kind=8),dimension(3) :: erij
2386       real(kind=8) :: delta=1.0d-7
2387 !el local variables
2388       integer :: i,j,k,l
2389
2390       call vec_and_deriv
2391 !d      do i=1,nres
2392 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2393 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2394 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2395 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2396 !d     &     (dc_norm(if90,i),if90=1,3)
2397 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2398 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2399 !d          write(iout,'(a)')
2400 !d      enddo
2401       do i=1,nres
2402         do j=1,2
2403           do k=1,3
2404             do l=1,3
2405               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2406               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2407             enddo
2408           enddo
2409         enddo
2410       enddo
2411       call vec_and_deriv
2412       do i=1,nres
2413         do j=1,3
2414           uyt(j,i)=uy(j,i)
2415           uzt(j,i)=uz(j,i)
2416         enddo
2417       enddo
2418       do i=1,nres
2419 !d        write (iout,*) 'i=',i
2420         do k=1,3
2421           erij(k)=dc_norm(k,i)
2422         enddo
2423         do j=1,3
2424           do k=1,3
2425             dc_norm(k,i)=erij(k)
2426           enddo
2427           dc_norm(j,i)=dc_norm(j,i)+delta
2428 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2429 !          do k=1,3
2430 !            dc_norm(k,i)=dc_norm(k,i)/fac
2431 !          enddo
2432 !          write (iout,*) (dc_norm(k,i),k=1,3)
2433 !          write (iout,*) (erij(k),k=1,3)
2434           call vec_and_deriv
2435           do k=1,3
2436             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2437             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2438             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2439             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2440           enddo
2441 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2442 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2443 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2444         enddo
2445         do k=1,3
2446           dc_norm(k,i)=erij(k)
2447         enddo
2448 !d        do k=1,3
2449 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2450 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2451 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2452 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2453 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2454 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2455 !d          write (iout,'(a)')
2456 !d        enddo
2457       enddo
2458       return
2459       end subroutine check_vecgrad
2460 !-----------------------------------------------------------------------------
2461       subroutine set_matrices
2462 !      implicit real*8 (a-h,o-z)
2463 !      include 'DIMENSIONS'
2464 #ifdef MPI
2465       include "mpif.h"
2466 !      include "COMMON.SETUP"
2467       integer :: IERR
2468       integer :: status(MPI_STATUS_SIZE)
2469 #endif
2470 !      include 'COMMON.IOUNITS'
2471 !      include 'COMMON.GEO'
2472 !      include 'COMMON.VAR'
2473 !      include 'COMMON.LOCAL'
2474 !      include 'COMMON.CHAIN'
2475 !      include 'COMMON.DERIV'
2476 !      include 'COMMON.INTERACT'
2477 !      include 'COMMON.CONTACTS'
2478 !      include 'COMMON.TORSION'
2479 !      include 'COMMON.VECTORS'
2480 !      include 'COMMON.FFIELD'
2481       real(kind=8) :: auxvec(2),auxmat(2,2)
2482       integer :: i,iti1,iti,k,l
2483       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2484 !       print *,"in set matrices"
2485 !
2486 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2487 ! to calculate the el-loc multibody terms of various order.
2488 !
2489 !AL el      mu=0.0d0
2490 #ifdef PARMAT
2491       do i=ivec_start+2,ivec_end+2
2492 #else
2493       do i=3,nres+1
2494 #endif
2495 !      print *,i,"i"
2496         if (i .lt. nres+1) then
2497           sin1=dsin(phi(i))
2498           cos1=dcos(phi(i))
2499           sintab(i-2)=sin1
2500           costab(i-2)=cos1
2501           obrot(1,i-2)=cos1
2502           obrot(2,i-2)=sin1
2503           sin2=dsin(2*phi(i))
2504           cos2=dcos(2*phi(i))
2505           sintab2(i-2)=sin2
2506           costab2(i-2)=cos2
2507           obrot2(1,i-2)=cos2
2508           obrot2(2,i-2)=sin2
2509           Ug(1,1,i-2)=-cos1
2510           Ug(1,2,i-2)=-sin1
2511           Ug(2,1,i-2)=-sin1
2512           Ug(2,2,i-2)= cos1
2513           Ug2(1,1,i-2)=-cos2
2514           Ug2(1,2,i-2)=-sin2
2515           Ug2(2,1,i-2)=-sin2
2516           Ug2(2,2,i-2)= cos2
2517         else
2518           costab(i-2)=1.0d0
2519           sintab(i-2)=0.0d0
2520           obrot(1,i-2)=1.0d0
2521           obrot(2,i-2)=0.0d0
2522           obrot2(1,i-2)=0.0d0
2523           obrot2(2,i-2)=0.0d0
2524           Ug(1,1,i-2)=1.0d0
2525           Ug(1,2,i-2)=0.0d0
2526           Ug(2,1,i-2)=0.0d0
2527           Ug(2,2,i-2)=1.0d0
2528           Ug2(1,1,i-2)=0.0d0
2529           Ug2(1,2,i-2)=0.0d0
2530           Ug2(2,1,i-2)=0.0d0
2531           Ug2(2,2,i-2)=0.0d0
2532         endif
2533         if (i .gt. 3 .and. i .lt. nres+1) then
2534           obrot_der(1,i-2)=-sin1
2535           obrot_der(2,i-2)= cos1
2536           Ugder(1,1,i-2)= sin1
2537           Ugder(1,2,i-2)=-cos1
2538           Ugder(2,1,i-2)=-cos1
2539           Ugder(2,2,i-2)=-sin1
2540           dwacos2=cos2+cos2
2541           dwasin2=sin2+sin2
2542           obrot2_der(1,i-2)=-dwasin2
2543           obrot2_der(2,i-2)= dwacos2
2544           Ug2der(1,1,i-2)= dwasin2
2545           Ug2der(1,2,i-2)=-dwacos2
2546           Ug2der(2,1,i-2)=-dwacos2
2547           Ug2der(2,2,i-2)=-dwasin2
2548         else
2549           obrot_der(1,i-2)=0.0d0
2550           obrot_der(2,i-2)=0.0d0
2551           Ugder(1,1,i-2)=0.0d0
2552           Ugder(1,2,i-2)=0.0d0
2553           Ugder(2,1,i-2)=0.0d0
2554           Ugder(2,2,i-2)=0.0d0
2555           obrot2_der(1,i-2)=0.0d0
2556           obrot2_der(2,i-2)=0.0d0
2557           Ug2der(1,1,i-2)=0.0d0
2558           Ug2der(1,2,i-2)=0.0d0
2559           Ug2der(2,1,i-2)=0.0d0
2560           Ug2der(2,2,i-2)=0.0d0
2561         endif
2562 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2563         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2564           iti = itortyp(itype(i-2,1))
2565         else
2566           iti=ntortyp+1
2567         endif
2568 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2569         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2570           iti1 = itortyp(itype(i-1,1))
2571         else
2572           iti1=ntortyp+1
2573         endif
2574 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2575 !d        write (iout,*) '*******i',i,' iti1',iti
2576 !d        write (iout,*) 'b1',b1(:,iti)
2577 !d        write (iout,*) 'b2',b2(:,iti)
2578 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2579 !        if (i .gt. iatel_s+2) then
2580         if (i .gt. nnt+2) then
2581           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2582           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2583           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2584           then
2585           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2586           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2587           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2588           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2589           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2590           endif
2591         else
2592           do k=1,2
2593             Ub2(k,i-2)=0.0d0
2594             Ctobr(k,i-2)=0.0d0
2595             Dtobr2(k,i-2)=0.0d0
2596             do l=1,2
2597               EUg(l,k,i-2)=0.0d0
2598               CUg(l,k,i-2)=0.0d0
2599               DUg(l,k,i-2)=0.0d0
2600               DtUg2(l,k,i-2)=0.0d0
2601             enddo
2602           enddo
2603         endif
2604         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2605         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2606         do k=1,2
2607           muder(k,i-2)=Ub2der(k,i-2)
2608         enddo
2609 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2610         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2611           if (itype(i-1,1).le.ntyp) then
2612             iti1 = itortyp(itype(i-1,1))
2613           else
2614             iti1=ntortyp+1
2615           endif
2616         else
2617           iti1=ntortyp+1
2618         endif
2619         do k=1,2
2620           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2621         enddo
2622 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2623 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2624 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2625 !d        write (iout,*) 'mu1',mu1(:,i-2)
2626 !d        write (iout,*) 'mu2',mu2(:,i-2)
2627         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2628         then
2629         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2630         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2631         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2632         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2633         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2634 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2635         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2636         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2637         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2638         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2639         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2640         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2641         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2642         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2643         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2644         endif
2645       enddo
2646 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2647 ! The order of matrices is from left to right.
2648       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2649       then
2650 !      do i=max0(ivec_start,2),ivec_end
2651       do i=2,nres-1
2652         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2653         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2654         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2655         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2656         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2657         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2658         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2659         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2660       enddo
2661       endif
2662 #if defined(MPI) && defined(PARMAT)
2663 #ifdef DEBUG
2664 !      if (fg_rank.eq.0) then
2665         write (iout,*) "Arrays UG and UGDER before GATHER"
2666         do i=1,nres-1
2667           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2668            ((ug(l,k,i),l=1,2),k=1,2),&
2669            ((ugder(l,k,i),l=1,2),k=1,2)
2670         enddo
2671         write (iout,*) "Arrays UG2 and UG2DER"
2672         do i=1,nres-1
2673           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2674            ((ug2(l,k,i),l=1,2),k=1,2),&
2675            ((ug2der(l,k,i),l=1,2),k=1,2)
2676         enddo
2677         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2678         do i=1,nres-1
2679           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2680            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2681            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2682         enddo
2683         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2684         do i=1,nres-1
2685           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2686            costab(i),sintab(i),costab2(i),sintab2(i)
2687         enddo
2688         write (iout,*) "Array MUDER"
2689         do i=1,nres-1
2690           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2691         enddo
2692 !      endif
2693 #endif
2694       if (nfgtasks.gt.1) then
2695         time00=MPI_Wtime()
2696 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2697 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2698 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2699 #ifdef MATGATHER
2700         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2701          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2702          FG_COMM1,IERR)
2703         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2704          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2705          FG_COMM1,IERR)
2706         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2707          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2708          FG_COMM1,IERR)
2709         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2710          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2711          FG_COMM1,IERR)
2712         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2713          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2714          FG_COMM1,IERR)
2715         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2716          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2717          FG_COMM1,IERR)
2718         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2719          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2720          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2721         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2722          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2723          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2724         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2725          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2726          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2727         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2728          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2729          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2730         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2731         then
2732         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2733          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2734          FG_COMM1,IERR)
2735         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2736          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2737          FG_COMM1,IERR)
2738         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2739          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2740          FG_COMM1,IERR)
2741        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2742          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2743          FG_COMM1,IERR)
2744         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2745          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2746          FG_COMM1,IERR)
2747         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2748          ivec_count(fg_rank1),&
2749          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2750          FG_COMM1,IERR)
2751         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2752          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2753          FG_COMM1,IERR)
2754         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2755          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2756          FG_COMM1,IERR)
2757         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2758          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2759          FG_COMM1,IERR)
2760         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2761          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2762          FG_COMM1,IERR)
2763         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2764          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2765          FG_COMM1,IERR)
2766         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2767          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2768          FG_COMM1,IERR)
2769         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2770          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2771          FG_COMM1,IERR)
2772         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2773          ivec_count(fg_rank1),&
2774          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2775          FG_COMM1,IERR)
2776         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2777          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2778          FG_COMM1,IERR)
2779        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2780          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2781          FG_COMM1,IERR)
2782         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2783          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2784          FG_COMM1,IERR)
2785        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2786          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2787          FG_COMM1,IERR)
2788         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2789          ivec_count(fg_rank1),&
2790          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2791          FG_COMM1,IERR)
2792         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2793          ivec_count(fg_rank1),&
2794          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2795          FG_COMM1,IERR)
2796         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2797          ivec_count(fg_rank1),&
2798          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2799          MPI_MAT2,FG_COMM1,IERR)
2800         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2801          ivec_count(fg_rank1),&
2802          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2803          MPI_MAT2,FG_COMM1,IERR)
2804         endif
2805 #else
2806 ! Passes matrix info through the ring
2807       isend=fg_rank1
2808       irecv=fg_rank1-1
2809       if (irecv.lt.0) irecv=nfgtasks1-1
2810       iprev=irecv
2811       inext=fg_rank1+1
2812       if (inext.ge.nfgtasks1) inext=0
2813       do i=1,nfgtasks1-1
2814 !        write (iout,*) "isend",isend," irecv",irecv
2815 !        call flush(iout)
2816         lensend=lentyp(isend)
2817         lenrecv=lentyp(irecv)
2818 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2819 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2820 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2821 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2822 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2823 !        write (iout,*) "Gather ROTAT1"
2824 !        call flush(iout)
2825 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2826 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2827 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2828 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2829 !        write (iout,*) "Gather ROTAT2"
2830 !        call flush(iout)
2831         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2832          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2833          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2834          iprev,4400+irecv,FG_COMM,status,IERR)
2835 !        write (iout,*) "Gather ROTAT_OLD"
2836 !        call flush(iout)
2837         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2838          MPI_PRECOMP11(lensend),inext,5500+isend,&
2839          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2840          iprev,5500+irecv,FG_COMM,status,IERR)
2841 !        write (iout,*) "Gather PRECOMP11"
2842 !        call flush(iout)
2843         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2844          MPI_PRECOMP12(lensend),inext,6600+isend,&
2845          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2846          iprev,6600+irecv,FG_COMM,status,IERR)
2847 !        write (iout,*) "Gather PRECOMP12"
2848 !        call flush(iout)
2849         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2850         then
2851         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2852          MPI_ROTAT2(lensend),inext,7700+isend,&
2853          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2854          iprev,7700+irecv,FG_COMM,status,IERR)
2855 !        write (iout,*) "Gather PRECOMP21"
2856 !        call flush(iout)
2857         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2858          MPI_PRECOMP22(lensend),inext,8800+isend,&
2859          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2860          iprev,8800+irecv,FG_COMM,status,IERR)
2861 !        write (iout,*) "Gather PRECOMP22"
2862 !        call flush(iout)
2863         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2864          MPI_PRECOMP23(lensend),inext,9900+isend,&
2865          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2866          MPI_PRECOMP23(lenrecv),&
2867          iprev,9900+irecv,FG_COMM,status,IERR)
2868 !        write (iout,*) "Gather PRECOMP23"
2869 !        call flush(iout)
2870         endif
2871         isend=irecv
2872         irecv=irecv-1
2873         if (irecv.lt.0) irecv=nfgtasks1-1
2874       enddo
2875 #endif
2876         time_gather=time_gather+MPI_Wtime()-time00
2877       endif
2878 #ifdef DEBUG
2879 !      if (fg_rank.eq.0) then
2880         write (iout,*) "Arrays UG and UGDER"
2881         do i=1,nres-1
2882           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2883            ((ug(l,k,i),l=1,2),k=1,2),&
2884            ((ugder(l,k,i),l=1,2),k=1,2)
2885         enddo
2886         write (iout,*) "Arrays UG2 and UG2DER"
2887         do i=1,nres-1
2888           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2889            ((ug2(l,k,i),l=1,2),k=1,2),&
2890            ((ug2der(l,k,i),l=1,2),k=1,2)
2891         enddo
2892         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2893         do i=1,nres-1
2894           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2895            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2896            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2897         enddo
2898         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2899         do i=1,nres-1
2900           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2901            costab(i),sintab(i),costab2(i),sintab2(i)
2902         enddo
2903         write (iout,*) "Array MUDER"
2904         do i=1,nres-1
2905           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2906         enddo
2907 !      endif
2908 #endif
2909 #endif
2910 !d      do i=1,nres
2911 !d        iti = itortyp(itype(i,1))
2912 !d        write (iout,*) i
2913 !d        do j=1,2
2914 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2915 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2916 !d        enddo
2917 !d      enddo
2918       return
2919       end subroutine set_matrices
2920 !-----------------------------------------------------------------------------
2921       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2922 !
2923 ! This subroutine calculates the average interaction energy and its gradient
2924 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2925 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2926 ! The potential depends both on the distance of peptide-group centers and on
2927 ! the orientation of the CA-CA virtual bonds.
2928 !
2929       use comm_locel
2930 !      implicit real*8 (a-h,o-z)
2931 #ifdef MPI
2932       include 'mpif.h'
2933 #endif
2934 !      include 'DIMENSIONS'
2935 !      include 'COMMON.CONTROL'
2936 !      include 'COMMON.SETUP'
2937 !      include 'COMMON.IOUNITS'
2938 !      include 'COMMON.GEO'
2939 !      include 'COMMON.VAR'
2940 !      include 'COMMON.LOCAL'
2941 !      include 'COMMON.CHAIN'
2942 !      include 'COMMON.DERIV'
2943 !      include 'COMMON.INTERACT'
2944 !      include 'COMMON.CONTACTS'
2945 !      include 'COMMON.TORSION'
2946 !      include 'COMMON.VECTORS'
2947 !      include 'COMMON.FFIELD'
2948 !      include 'COMMON.TIME1'
2949       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2950       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2951       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2952 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2953       real(kind=8),dimension(4) :: muij
2954 !el      integer :: num_conti,j1,j2
2955 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2956 !el        dz_normi,xmedi,ymedi,zmedi
2957
2958 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2959 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2960 !el          num_conti,j1,j2
2961
2962 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2963 #ifdef MOMENT
2964       real(kind=8) :: scal_el=1.0d0
2965 #else
2966       real(kind=8) :: scal_el=0.5d0
2967 #endif
2968 ! 12/13/98
2969 ! 13-go grudnia roku pamietnego...
2970       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
2971                                              0.0d0,1.0d0,0.0d0,&
2972                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
2973 !el local variables
2974       integer :: i,k,j
2975       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2976       real(kind=8) :: fac,t_eelecij,fracinbuf
2977
2978
2979 !d      write(iout,*) 'In EELEC'
2980 !        print *,"IN EELEC"
2981 !d      do i=1,nloctyp
2982 !d        write(iout,*) 'Type',i
2983 !d        write(iout,*) 'B1',B1(:,i)
2984 !d        write(iout,*) 'B2',B2(:,i)
2985 !d        write(iout,*) 'CC',CC(:,:,i)
2986 !d        write(iout,*) 'DD',DD(:,:,i)
2987 !d        write(iout,*) 'EE',EE(:,:,i)
2988 !d      enddo
2989 !d      call check_vecgrad
2990 !d      stop
2991 !      ees=0.0d0  !AS
2992 !      evdw1=0.0d0
2993 !      eel_loc=0.0d0
2994 !      eello_turn3=0.0d0
2995 !      eello_turn4=0.0d0
2996       t_eelecij=0.0d0
2997       ees=0.0D0
2998       evdw1=0.0D0
2999       eel_loc=0.0d0
3000       eello_turn3=0.0d0
3001       eello_turn4=0.0d0
3002 !
3003
3004       if (icheckgrad.eq.1) then
3005 !el
3006 !        do i=0,2*nres+2
3007 !          dc_norm(1,i)=0.0d0
3008 !          dc_norm(2,i)=0.0d0
3009 !          dc_norm(3,i)=0.0d0
3010 !        enddo
3011         do i=1,nres-1
3012           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3013           do k=1,3
3014             dc_norm(k,i)=dc(k,i)*fac
3015           enddo
3016 !          write (iout,*) 'i',i,' fac',fac
3017         enddo
3018       endif
3019 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3020 !        wturn6
3021       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3022           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3023           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3024 !        call vec_and_deriv
3025 #ifdef TIMING
3026         time01=MPI_Wtime()
3027 #endif
3028 !        print *, "before set matrices"
3029         call set_matrices
3030 !        print *, "after set matrices"
3031
3032 #ifdef TIMING
3033         time_mat=time_mat+MPI_Wtime()-time01
3034 #endif
3035       endif
3036 !       print *, "after set matrices"
3037 !d      do i=1,nres-1
3038 !d        write (iout,*) 'i=',i
3039 !d        do k=1,3
3040 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3041 !d        enddo
3042 !d        do k=1,3
3043 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3044 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3045 !d        enddo
3046 !d      enddo
3047       t_eelecij=0.0d0
3048       ees=0.0D0
3049       evdw1=0.0D0
3050       eel_loc=0.0d0
3051       eello_turn3=0.0d0
3052       eello_turn4=0.0d0
3053 !el      ind=0
3054       do i=1,nres
3055         num_cont_hb(i)=0
3056       enddo
3057 !d      print '(a)','Enter EELEC'
3058 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3059 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3060 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3061       do i=1,nres
3062         gel_loc_loc(i)=0.0d0
3063         gcorr_loc(i)=0.0d0
3064       enddo
3065 !
3066 !
3067 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3068 !
3069 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3070 !
3071
3072
3073 !        print *,"before iturn3 loop"
3074       do i=iturn3_start,iturn3_end
3075         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3076         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3077         dxi=dc(1,i)
3078         dyi=dc(2,i)
3079         dzi=dc(3,i)
3080         dx_normi=dc_norm(1,i)
3081         dy_normi=dc_norm(2,i)
3082         dz_normi=dc_norm(3,i)
3083         xmedi=c(1,i)+0.5d0*dxi
3084         ymedi=c(2,i)+0.5d0*dyi
3085         zmedi=c(3,i)+0.5d0*dzi
3086           xmedi=dmod(xmedi,boxxsize)
3087           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3088           ymedi=dmod(ymedi,boxysize)
3089           if (ymedi.lt.0) ymedi=ymedi+boxysize
3090           zmedi=dmod(zmedi,boxzsize)
3091           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3092         num_conti=0
3093        if ((zmedi.gt.bordlipbot) &
3094         .and.(zmedi.lt.bordliptop)) then
3095 !C the energy transfer exist
3096         if (zmedi.lt.buflipbot) then
3097 !C what fraction I am in
3098          fracinbuf=1.0d0- &
3099                ((zmedi-bordlipbot)/lipbufthick)
3100 !C lipbufthick is thickenes of lipid buffore
3101          sslipi=sscalelip(fracinbuf)
3102          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3103         elseif (zmedi.gt.bufliptop) then
3104          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3105          sslipi=sscalelip(fracinbuf)
3106          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3107         else
3108          sslipi=1.0d0
3109          ssgradlipi=0.0
3110         endif
3111        else
3112          sslipi=0.0d0
3113          ssgradlipi=0.0
3114        endif
3115 !       print *,i,sslipi,ssgradlipi
3116        call eelecij(i,i+2,ees,evdw1,eel_loc)
3117         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3118         num_cont_hb(i)=num_conti
3119       enddo
3120       do i=iturn4_start,iturn4_end
3121         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3122           .or. itype(i+3,1).eq.ntyp1 &
3123           .or. itype(i+4,1).eq.ntyp1) cycle
3124         dxi=dc(1,i)
3125         dyi=dc(2,i)
3126         dzi=dc(3,i)
3127         dx_normi=dc_norm(1,i)
3128         dy_normi=dc_norm(2,i)
3129         dz_normi=dc_norm(3,i)
3130         xmedi=c(1,i)+0.5d0*dxi
3131         ymedi=c(2,i)+0.5d0*dyi
3132         zmedi=c(3,i)+0.5d0*dzi
3133           xmedi=dmod(xmedi,boxxsize)
3134           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3135           ymedi=dmod(ymedi,boxysize)
3136           if (ymedi.lt.0) ymedi=ymedi+boxysize
3137           zmedi=dmod(zmedi,boxzsize)
3138           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3139        if ((zmedi.gt.bordlipbot)  &
3140        .and.(zmedi.lt.bordliptop)) then
3141 !C the energy transfer exist
3142         if (zmedi.lt.buflipbot) then
3143 !C what fraction I am in
3144          fracinbuf=1.0d0- &
3145              ((zmedi-bordlipbot)/lipbufthick)
3146 !C lipbufthick is thickenes of lipid buffore
3147          sslipi=sscalelip(fracinbuf)
3148          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3149         elseif (zmedi.gt.bufliptop) then
3150          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3151          sslipi=sscalelip(fracinbuf)
3152          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3153         else
3154          sslipi=1.0d0
3155          ssgradlipi=0.0
3156         endif
3157        else
3158          sslipi=0.0d0
3159          ssgradlipi=0.0
3160        endif
3161
3162         num_conti=num_cont_hb(i)
3163         call eelecij(i,i+3,ees,evdw1,eel_loc)
3164         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3165          call eturn4(i,eello_turn4)
3166         num_cont_hb(i)=num_conti
3167       enddo   ! i
3168 !
3169 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3170 !
3171 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3172       do i=iatel_s,iatel_e
3173         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3174         dxi=dc(1,i)
3175         dyi=dc(2,i)
3176         dzi=dc(3,i)
3177         dx_normi=dc_norm(1,i)
3178         dy_normi=dc_norm(2,i)
3179         dz_normi=dc_norm(3,i)
3180         xmedi=c(1,i)+0.5d0*dxi
3181         ymedi=c(2,i)+0.5d0*dyi
3182         zmedi=c(3,i)+0.5d0*dzi
3183           xmedi=dmod(xmedi,boxxsize)
3184           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3185           ymedi=dmod(ymedi,boxysize)
3186           if (ymedi.lt.0) ymedi=ymedi+boxysize
3187           zmedi=dmod(zmedi,boxzsize)
3188           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3189        if ((zmedi.gt.bordlipbot)  &
3190         .and.(zmedi.lt.bordliptop)) then
3191 !C the energy transfer exist
3192         if (zmedi.lt.buflipbot) then
3193 !C what fraction I am in
3194          fracinbuf=1.0d0- &
3195              ((zmedi-bordlipbot)/lipbufthick)
3196 !C lipbufthick is thickenes of lipid buffore
3197          sslipi=sscalelip(fracinbuf)
3198          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3199         elseif (zmedi.gt.bufliptop) then
3200          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3201          sslipi=sscalelip(fracinbuf)
3202          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3203         else
3204          sslipi=1.0d0
3205          ssgradlipi=0.0
3206         endif
3207        else
3208          sslipi=0.0d0
3209          ssgradlipi=0.0
3210        endif
3211
3212 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3213         num_conti=num_cont_hb(i)
3214         do j=ielstart(i),ielend(i)
3215 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3216           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3217           call eelecij(i,j,ees,evdw1,eel_loc)
3218         enddo ! j
3219         num_cont_hb(i)=num_conti
3220       enddo   ! i
3221 !      write (iout,*) "Number of loop steps in EELEC:",ind
3222 !d      do i=1,nres
3223 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3224 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3225 !d      enddo
3226 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3227 !cc      eel_loc=eel_loc+eello_turn3
3228 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3229       return
3230       end subroutine eelec
3231 !-----------------------------------------------------------------------------
3232       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3233
3234       use comm_locel
3235 !      implicit real*8 (a-h,o-z)
3236 !      include 'DIMENSIONS'
3237 #ifdef MPI
3238       include "mpif.h"
3239 #endif
3240 !      include 'COMMON.CONTROL'
3241 !      include 'COMMON.IOUNITS'
3242 !      include 'COMMON.GEO'
3243 !      include 'COMMON.VAR'
3244 !      include 'COMMON.LOCAL'
3245 !      include 'COMMON.CHAIN'
3246 !      include 'COMMON.DERIV'
3247 !      include 'COMMON.INTERACT'
3248 !      include 'COMMON.CONTACTS'
3249 !      include 'COMMON.TORSION'
3250 !      include 'COMMON.VECTORS'
3251 !      include 'COMMON.FFIELD'
3252 !      include 'COMMON.TIME1'
3253       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3254       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3255       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3256 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3257       real(kind=8),dimension(4) :: muij
3258       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3259                     dist_temp, dist_init,rlocshield,fracinbuf
3260       integer xshift,yshift,zshift,ilist,iresshield
3261 !el      integer :: num_conti,j1,j2
3262 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3263 !el        dz_normi,xmedi,ymedi,zmedi
3264
3265 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3266 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3267 !el          num_conti,j1,j2
3268
3269 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3270 #ifdef MOMENT
3271       real(kind=8) :: scal_el=1.0d0
3272 #else
3273       real(kind=8) :: scal_el=0.5d0
3274 #endif
3275 ! 12/13/98
3276 ! 13-go grudnia roku pamietnego...
3277       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3278                                              0.0d0,1.0d0,0.0d0,&
3279                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3280 !      integer :: maxconts=nres/4
3281 !el local variables
3282       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3283       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3284       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3285       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3286                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3287                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3288                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3289                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3290                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3291                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3292                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3293 !      maxconts=nres/4
3294 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3295 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3296
3297 !          time00=MPI_Wtime()
3298 !d      write (iout,*) "eelecij",i,j
3299 !          ind=ind+1
3300           iteli=itel(i)
3301           itelj=itel(j)
3302           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3303           aaa=app(iteli,itelj)
3304           bbb=bpp(iteli,itelj)
3305           ael6i=ael6(iteli,itelj)
3306           ael3i=ael3(iteli,itelj)
3307           dxj=dc(1,j)
3308           dyj=dc(2,j)
3309           dzj=dc(3,j)
3310           dx_normj=dc_norm(1,j)
3311           dy_normj=dc_norm(2,j)
3312           dz_normj=dc_norm(3,j)
3313 !          xj=c(1,j)+0.5D0*dxj-xmedi
3314 !          yj=c(2,j)+0.5D0*dyj-ymedi
3315 !          zj=c(3,j)+0.5D0*dzj-zmedi
3316           xj=c(1,j)+0.5D0*dxj
3317           yj=c(2,j)+0.5D0*dyj
3318           zj=c(3,j)+0.5D0*dzj
3319           xj=mod(xj,boxxsize)
3320           if (xj.lt.0) xj=xj+boxxsize
3321           yj=mod(yj,boxysize)
3322           if (yj.lt.0) yj=yj+boxysize
3323           zj=mod(zj,boxzsize)
3324           if (zj.lt.0) zj=zj+boxzsize
3325        if ((zj.gt.bordlipbot)  &
3326        .and.(zj.lt.bordliptop)) then
3327 !C the energy transfer exist
3328         if (zj.lt.buflipbot) then
3329 !C what fraction I am in
3330          fracinbuf=1.0d0-     &
3331              ((zj-bordlipbot)/lipbufthick)
3332 !C lipbufthick is thickenes of lipid buffore
3333          sslipj=sscalelip(fracinbuf)
3334          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3335         elseif (zj.gt.bufliptop) then
3336          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3337          sslipj=sscalelip(fracinbuf)
3338          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3339         else
3340          sslipj=1.0d0
3341          ssgradlipj=0.0
3342         endif
3343        else
3344          sslipj=0.0d0
3345          ssgradlipj=0.0
3346        endif
3347
3348       isubchap=0
3349       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3350       xj_safe=xj
3351       yj_safe=yj
3352       zj_safe=zj
3353       do xshift=-1,1
3354       do yshift=-1,1
3355       do zshift=-1,1
3356           xj=xj_safe+xshift*boxxsize
3357           yj=yj_safe+yshift*boxysize
3358           zj=zj_safe+zshift*boxzsize
3359           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3360           if(dist_temp.lt.dist_init) then
3361             dist_init=dist_temp
3362             xj_temp=xj
3363             yj_temp=yj
3364             zj_temp=zj
3365             isubchap=1
3366           endif
3367        enddo
3368        enddo
3369        enddo
3370        if (isubchap.eq.1) then
3371 !C          print *,i,j
3372           xj=xj_temp-xmedi
3373           yj=yj_temp-ymedi
3374           zj=zj_temp-zmedi
3375        else
3376           xj=xj_safe-xmedi
3377           yj=yj_safe-ymedi
3378           zj=zj_safe-zmedi
3379        endif
3380
3381           rij=xj*xj+yj*yj+zj*zj
3382           rrmij=1.0D0/rij
3383           rij=dsqrt(rij)
3384 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3385             sss_ele_cut=sscale_ele(rij)
3386             sss_ele_grad=sscagrad_ele(rij)
3387 !             sss_ele_cut=1.0d0
3388 !             sss_ele_grad=0.0d0
3389 !            print *,sss_ele_cut,sss_ele_grad,&
3390 !            (rij),r_cut_ele,rlamb_ele
3391 !            if (sss_ele_cut.le.0.0) go to 128
3392
3393           rmij=1.0D0/rij
3394           r3ij=rrmij*rmij
3395           r6ij=r3ij*r3ij
3396           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3397           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3398           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3399           fac=cosa-3.0D0*cosb*cosg
3400           ev1=aaa*r6ij*r6ij
3401 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3402           if (j.eq.i+2) ev1=scal_el*ev1
3403           ev2=bbb*r6ij
3404           fac3=ael6i*r6ij
3405           fac4=ael3i*r3ij
3406           evdwij=ev1+ev2
3407           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3408           el2=fac4*fac
3409 !          eesij=el1+el2
3410           if (shield_mode.gt.0) then
3411 !C          fac_shield(i)=0.4
3412 !C          fac_shield(j)=0.6
3413           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3414           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3415           eesij=(el1+el2)
3416           ees=ees+eesij*sss_ele_cut
3417 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3418 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3419           else
3420           fac_shield(i)=1.0
3421           fac_shield(j)=1.0
3422           eesij=(el1+el2)
3423           ees=ees+eesij   &
3424             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3425 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3426           endif
3427
3428 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3429           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3430 !          ees=ees+eesij*sss_ele_cut
3431           evdw1=evdw1+evdwij*sss_ele_cut  &
3432            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3433 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3434 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3435 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3436 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3437
3438           if (energy_dec) then
3439 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3440 !                  'evdw1',i,j,evdwij,&
3441 !                  iteli,itelj,aaa,evdw1
3442               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3443               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3444           endif
3445 !
3446 ! Calculate contributions to the Cartesian gradient.
3447 !
3448 #ifdef SPLITELE
3449           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3450               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3451           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3452              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3453           fac1=fac
3454           erij(1)=xj*rmij
3455           erij(2)=yj*rmij
3456           erij(3)=zj*rmij
3457 !
3458 ! Radial derivatives. First process both termini of the fragment (i,j)
3459 !
3460           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3461           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3462           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3463            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3464           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3465             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3466
3467           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3468           (shield_mode.gt.0)) then
3469 !C          print *,i,j
3470           do ilist=1,ishield_list(i)
3471            iresshield=shield_list(ilist,i)
3472            do k=1,3
3473            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3474            *2.0*sss_ele_cut
3475            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3476                    rlocshield &
3477             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3478             *sss_ele_cut
3479             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3480            enddo
3481           enddo
3482           do ilist=1,ishield_list(j)
3483            iresshield=shield_list(ilist,j)
3484            do k=1,3
3485            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3486           *2.0*sss_ele_cut
3487            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3488                    rlocshield &
3489            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3490            *sss_ele_cut
3491            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3492            enddo
3493           enddo
3494           do k=1,3
3495             gshieldc(k,i)=gshieldc(k,i)+ &
3496                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3497            *sss_ele_cut
3498
3499             gshieldc(k,j)=gshieldc(k,j)+ &
3500                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3501            *sss_ele_cut
3502
3503             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3504                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3505            *sss_ele_cut
3506
3507             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3508                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3509            *sss_ele_cut
3510
3511            enddo
3512            endif
3513
3514
3515 !          do k=1,3
3516 !            ghalf=0.5D0*ggg(k)
3517 !            gelc(k,i)=gelc(k,i)+ghalf
3518 !            gelc(k,j)=gelc(k,j)+ghalf
3519 !          enddo
3520 ! 9/28/08 AL Gradient compotents will be summed only at the end
3521           do k=1,3
3522             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3523             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3524           enddo
3525             gelc_long(3,j)=gelc_long(3,j)+  &
3526           ssgradlipj*eesij/2.0d0*lipscale**2&
3527            *sss_ele_cut
3528
3529             gelc_long(3,i)=gelc_long(3,i)+  &
3530           ssgradlipi*eesij/2.0d0*lipscale**2&
3531            *sss_ele_cut
3532
3533
3534 !
3535 ! Loop over residues i+1 thru j-1.
3536 !
3537 !grad          do k=i+1,j-1
3538 !grad            do l=1,3
3539 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3540 !grad            enddo
3541 !grad          enddo
3542           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3543            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3544           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3545            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3546           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3547            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3548
3549 !          do k=1,3
3550 !            ghalf=0.5D0*ggg(k)
3551 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3552 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3553 !          enddo
3554 ! 9/28/08 AL Gradient compotents will be summed only at the end
3555           do k=1,3
3556             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3557             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3558           enddo
3559
3560 !C Lipidic part for scaling weight
3561            gvdwpp(3,j)=gvdwpp(3,j)+ &
3562           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3563            gvdwpp(3,i)=gvdwpp(3,i)+ &
3564           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3565 !! Loop over residues i+1 thru j-1.
3566 !
3567 !grad          do k=i+1,j-1
3568 !grad            do l=1,3
3569 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3570 !grad            enddo
3571 !grad          enddo
3572 #else
3573           facvdw=(ev1+evdwij)*sss_ele_cut &
3574            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3575
3576           facel=(el1+eesij)*sss_ele_cut
3577           fac1=fac
3578           fac=-3*rrmij*(facvdw+facvdw+facel)
3579           erij(1)=xj*rmij
3580           erij(2)=yj*rmij
3581           erij(3)=zj*rmij
3582 !
3583 ! Radial derivatives. First process both termini of the fragment (i,j)
3584 !
3585           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3586           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3587           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3588 !          do k=1,3
3589 !            ghalf=0.5D0*ggg(k)
3590 !            gelc(k,i)=gelc(k,i)+ghalf
3591 !            gelc(k,j)=gelc(k,j)+ghalf
3592 !          enddo
3593 ! 9/28/08 AL Gradient compotents will be summed only at the end
3594           do k=1,3
3595             gelc_long(k,j)=gelc(k,j)+ggg(k)
3596             gelc_long(k,i)=gelc(k,i)-ggg(k)
3597           enddo
3598 !
3599 ! Loop over residues i+1 thru j-1.
3600 !
3601 !grad          do k=i+1,j-1
3602 !grad            do l=1,3
3603 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3604 !grad            enddo
3605 !grad          enddo
3606 ! 9/28/08 AL Gradient compotents will be summed only at the end
3607           ggg(1)=facvdw*xj &
3608            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3609           ggg(2)=facvdw*yj &
3610            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3611           ggg(3)=facvdw*zj &
3612            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3613
3614           do k=1,3
3615             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3616             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3617           enddo
3618            gvdwpp(3,j)=gvdwpp(3,j)+ &
3619           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3620            gvdwpp(3,i)=gvdwpp(3,i)+ &
3621           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3622
3623 #endif
3624 !
3625 ! Angular part
3626 !
3627           ecosa=2.0D0*fac3*fac1+fac4
3628           fac4=-3.0D0*fac4
3629           fac3=-6.0D0*fac3
3630           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3631           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3632           do k=1,3
3633             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3634             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3635           enddo
3636 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3637 !d   &          (dcosg(k),k=1,3)
3638           do k=1,3
3639             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3640              *fac_shield(i)**2*fac_shield(j)**2 &
3641              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3642
3643           enddo
3644 !          do k=1,3
3645 !            ghalf=0.5D0*ggg(k)
3646 !            gelc(k,i)=gelc(k,i)+ghalf
3647 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3648 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3649 !            gelc(k,j)=gelc(k,j)+ghalf
3650 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3651 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3652 !          enddo
3653 !grad          do k=i+1,j-1
3654 !grad            do l=1,3
3655 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3656 !grad            enddo
3657 !grad          enddo
3658           do k=1,3
3659             gelc(k,i)=gelc(k,i) &
3660                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3661                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3662                      *sss_ele_cut &
3663                      *fac_shield(i)**2*fac_shield(j)**2 &
3664                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3665
3666             gelc(k,j)=gelc(k,j) &
3667                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3668                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3669                      *sss_ele_cut  &
3670                      *fac_shield(i)**2*fac_shield(j)**2  &
3671                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3672
3673             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3674             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3675           enddo
3676
3677           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3678               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3679               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3680 !
3681 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3682 !   energy of a peptide unit is assumed in the form of a second-order
3683 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3684 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3685 !   are computed for EVERY pair of non-contiguous peptide groups.
3686 !
3687           if (j.lt.nres-1) then
3688             j1=j+1
3689             j2=j-1
3690           else
3691             j1=j-1
3692             j2=j-2
3693           endif
3694           kkk=0
3695           do k=1,2
3696             do l=1,2
3697               kkk=kkk+1
3698               muij(kkk)=mu(k,i)*mu(l,j)
3699             enddo
3700           enddo
3701 !d         write (iout,*) 'EELEC: i',i,' j',j
3702 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3703 !d          write(iout,*) 'muij',muij
3704           ury=scalar(uy(1,i),erij)
3705           urz=scalar(uz(1,i),erij)
3706           vry=scalar(uy(1,j),erij)
3707           vrz=scalar(uz(1,j),erij)
3708           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3709           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3710           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3711           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3712           fac=dsqrt(-ael6i)*r3ij
3713           a22=a22*fac
3714           a23=a23*fac
3715           a32=a32*fac
3716           a33=a33*fac
3717 !d          write (iout,'(4i5,4f10.5)')
3718 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3719 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3720 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3721 !d     &      uy(:,j),uz(:,j)
3722 !d          write (iout,'(4f10.5)')
3723 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3724 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3725 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3726 !d           write (iout,'(9f10.5/)')
3727 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3728 ! Derivatives of the elements of A in virtual-bond vectors
3729           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3730           do k=1,3
3731             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3732             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3733             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3734             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3735             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3736             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3737             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3738             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3739             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3740             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3741             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3742             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3743           enddo
3744 ! Compute radial contributions to the gradient
3745           facr=-3.0d0*rrmij
3746           a22der=a22*facr
3747           a23der=a23*facr
3748           a32der=a32*facr
3749           a33der=a33*facr
3750           agg(1,1)=a22der*xj
3751           agg(2,1)=a22der*yj
3752           agg(3,1)=a22der*zj
3753           agg(1,2)=a23der*xj
3754           agg(2,2)=a23der*yj
3755           agg(3,2)=a23der*zj
3756           agg(1,3)=a32der*xj
3757           agg(2,3)=a32der*yj
3758           agg(3,3)=a32der*zj
3759           agg(1,4)=a33der*xj
3760           agg(2,4)=a33der*yj
3761           agg(3,4)=a33der*zj
3762 ! Add the contributions coming from er
3763           fac3=-3.0d0*fac
3764           do k=1,3
3765             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3766             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3767             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3768             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3769           enddo
3770           do k=1,3
3771 ! Derivatives in DC(i)
3772 !grad            ghalf1=0.5d0*agg(k,1)
3773 !grad            ghalf2=0.5d0*agg(k,2)
3774 !grad            ghalf3=0.5d0*agg(k,3)
3775 !grad            ghalf4=0.5d0*agg(k,4)
3776             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3777             -3.0d0*uryg(k,2)*vry)!+ghalf1
3778             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3779             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3780             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3781             -3.0d0*urzg(k,2)*vry)!+ghalf3
3782             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3783             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3784 ! Derivatives in DC(i+1)
3785             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3786             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3787             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3788             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3789             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3790             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3791             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3792             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3793 ! Derivatives in DC(j)
3794             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3795             -3.0d0*vryg(k,2)*ury)!+ghalf1
3796             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3797             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3798             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3799             -3.0d0*vryg(k,2)*urz)!+ghalf3
3800             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3801             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3802 ! Derivatives in DC(j+1) or DC(nres-1)
3803             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3804             -3.0d0*vryg(k,3)*ury)
3805             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3806             -3.0d0*vrzg(k,3)*ury)
3807             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3808             -3.0d0*vryg(k,3)*urz)
3809             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3810             -3.0d0*vrzg(k,3)*urz)
3811 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3812 !grad              do l=1,4
3813 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3814 !grad              enddo
3815 !grad            endif
3816           enddo
3817           acipa(1,1)=a22
3818           acipa(1,2)=a23
3819           acipa(2,1)=a32
3820           acipa(2,2)=a33
3821           a22=-a22
3822           a23=-a23
3823           do l=1,2
3824             do k=1,3
3825               agg(k,l)=-agg(k,l)
3826               aggi(k,l)=-aggi(k,l)
3827               aggi1(k,l)=-aggi1(k,l)
3828               aggj(k,l)=-aggj(k,l)
3829               aggj1(k,l)=-aggj1(k,l)
3830             enddo
3831           enddo
3832           if (j.lt.nres-1) then
3833             a22=-a22
3834             a32=-a32
3835             do l=1,3,2
3836               do k=1,3
3837                 agg(k,l)=-agg(k,l)
3838                 aggi(k,l)=-aggi(k,l)
3839                 aggi1(k,l)=-aggi1(k,l)
3840                 aggj(k,l)=-aggj(k,l)
3841                 aggj1(k,l)=-aggj1(k,l)
3842               enddo
3843             enddo
3844           else
3845             a22=-a22
3846             a23=-a23
3847             a32=-a32
3848             a33=-a33
3849             do l=1,4
3850               do k=1,3
3851                 agg(k,l)=-agg(k,l)
3852                 aggi(k,l)=-aggi(k,l)
3853                 aggi1(k,l)=-aggi1(k,l)
3854                 aggj(k,l)=-aggj(k,l)
3855                 aggj1(k,l)=-aggj1(k,l)
3856               enddo
3857             enddo
3858           endif
3859           ENDIF ! WCORR
3860           IF (wel_loc.gt.0.0d0) THEN
3861 ! Contribution to the local-electrostatic energy coming from the i-j pair
3862           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3863            +a33*muij(4)
3864           if (shield_mode.eq.0) then
3865            fac_shield(i)=1.0
3866            fac_shield(j)=1.0
3867           endif
3868           eel_loc_ij=eel_loc_ij &
3869          *fac_shield(i)*fac_shield(j) &
3870          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3871 !C Now derivative over eel_loc
3872           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3873          (shield_mode.gt.0)) then
3874 !C          print *,i,j
3875
3876           do ilist=1,ishield_list(i)
3877            iresshield=shield_list(ilist,i)
3878            do k=1,3
3879            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3880                                                 /fac_shield(i)&
3881            *sss_ele_cut
3882            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3883                    rlocshield  &
3884           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3885           *sss_ele_cut
3886
3887             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3888            +rlocshield
3889            enddo
3890           enddo
3891           do ilist=1,ishield_list(j)
3892            iresshield=shield_list(ilist,j)
3893            do k=1,3
3894            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3895                                             /fac_shield(j)   &
3896             *sss_ele_cut
3897            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3898                    rlocshield  &
3899       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3900        *sss_ele_cut
3901
3902            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3903                   +rlocshield
3904
3905            enddo
3906           enddo
3907
3908           do k=1,3
3909             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3910                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3911                     *sss_ele_cut
3912             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3913                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3914                     *sss_ele_cut
3915             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3916                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3917                     *sss_ele_cut
3918             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3919                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3920                     *sss_ele_cut
3921
3922            enddo
3923            endif
3924
3925
3926 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3927 !           eel_loc_ij=0.0
3928           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3929                   'eelloc',i,j,eel_loc_ij
3930 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3931 !          if (energy_dec) write (iout,*) "muij",muij
3932 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3933
3934           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3935 ! Partial derivatives in virtual-bond dihedral angles gamma
3936           if (i.gt.1) &
3937           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3938                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3939                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3940                  *sss_ele_cut  &
3941           *fac_shield(i)*fac_shield(j) &
3942           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3943
3944           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3945                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3946                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3947                  *sss_ele_cut &
3948           *fac_shield(i)*fac_shield(j) &
3949           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3950 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3951 !          do l=1,3
3952 !            ggg(1)=(agg(1,1)*muij(1)+ &
3953 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3954 !            *sss_ele_cut &
3955 !             +eel_loc_ij*sss_ele_grad*rmij*xj
3956 !            ggg(2)=(agg(2,1)*muij(1)+ &
3957 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
3958 !            *sss_ele_cut &
3959 !             +eel_loc_ij*sss_ele_grad*rmij*yj
3960 !            ggg(3)=(agg(3,1)*muij(1)+ &
3961 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
3962 !            *sss_ele_cut &
3963 !             +eel_loc_ij*sss_ele_grad*rmij*zj
3964            xtemp(1)=xj
3965            xtemp(2)=yj
3966            xtemp(3)=zj
3967
3968            do l=1,3
3969             ggg(l)=(agg(l,1)*muij(1)+ &
3970                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
3971             *sss_ele_cut &
3972           *fac_shield(i)*fac_shield(j) &
3973           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
3974              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
3975
3976
3977             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3978             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3979 !grad            ghalf=0.5d0*ggg(l)
3980 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3981 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3982           enddo
3983             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
3984           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
3985           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3986
3987             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
3988           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
3989           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
3990
3991 !grad          do k=i+1,j2
3992 !grad            do l=1,3
3993 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3994 !grad            enddo
3995 !grad          enddo
3996 ! Remaining derivatives of eello
3997           do l=1,3
3998             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
3999                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4000             *sss_ele_cut &
4001           *fac_shield(i)*fac_shield(j) &
4002           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4003
4004 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4005             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4006                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4007             +aggi1(l,4)*muij(4))&
4008             *sss_ele_cut &
4009           *fac_shield(i)*fac_shield(j) &
4010           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4011
4012 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4013             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4014                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4015             *sss_ele_cut &
4016           *fac_shield(i)*fac_shield(j) &
4017           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4018
4019 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4020             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4021                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4022             +aggj1(l,4)*muij(4))&
4023             *sss_ele_cut &
4024           *fac_shield(i)*fac_shield(j) &
4025           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4026
4027 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4028           enddo
4029           ENDIF
4030 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4031 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4032           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4033              .and. num_conti.le.maxconts) then
4034 !            write (iout,*) i,j," entered corr"
4035 !
4036 ! Calculate the contact function. The ith column of the array JCONT will
4037 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4038 ! greater than I). The arrays FACONT and GACONT will contain the values of
4039 ! the contact function and its derivative.
4040 !           r0ij=1.02D0*rpp(iteli,itelj)
4041 !           r0ij=1.11D0*rpp(iteli,itelj)
4042             r0ij=2.20D0*rpp(iteli,itelj)
4043 !           r0ij=1.55D0*rpp(iteli,itelj)
4044             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4045 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4046             if (fcont.gt.0.0D0) then
4047               num_conti=num_conti+1
4048               if (num_conti.gt.maxconts) then
4049 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4050 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4051                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4052                                ' will skip next contacts for this conf.', num_conti
4053               else
4054                 jcont_hb(num_conti,i)=j
4055 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4056 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4057                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4058                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4059 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4060 !  terms.
4061                 d_cont(num_conti,i)=rij
4062 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4063 !     --- Electrostatic-interaction matrix ---
4064                 a_chuj(1,1,num_conti,i)=a22
4065                 a_chuj(1,2,num_conti,i)=a23
4066                 a_chuj(2,1,num_conti,i)=a32
4067                 a_chuj(2,2,num_conti,i)=a33
4068 !     --- Gradient of rij
4069                 do kkk=1,3
4070                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4071                 enddo
4072                 kkll=0
4073                 do k=1,2
4074                   do l=1,2
4075                     kkll=kkll+1
4076                     do m=1,3
4077                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4078                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4079                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4080                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4081                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4082                     enddo
4083                   enddo
4084                 enddo
4085                 ENDIF
4086                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4087 ! Calculate contact energies
4088                 cosa4=4.0D0*cosa
4089                 wij=cosa-3.0D0*cosb*cosg
4090                 cosbg1=cosb+cosg
4091                 cosbg2=cosb-cosg
4092 !               fac3=dsqrt(-ael6i)/r0ij**3
4093                 fac3=dsqrt(-ael6i)*r3ij
4094 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4095                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4096                 if (ees0tmp.gt.0) then
4097                   ees0pij=dsqrt(ees0tmp)
4098                 else
4099                   ees0pij=0
4100                 endif
4101                 if (shield_mode.eq.0) then
4102                 fac_shield(i)=1.0d0
4103                 fac_shield(j)=1.0d0
4104                 else
4105                 ees0plist(num_conti,i)=j
4106                 endif
4107 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4108                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4109                 if (ees0tmp.gt.0) then
4110                   ees0mij=dsqrt(ees0tmp)
4111                 else
4112                   ees0mij=0
4113                 endif
4114 !               ees0mij=0.0D0
4115                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4116                      *sss_ele_cut &
4117                      *fac_shield(i)*fac_shield(j)
4118
4119                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4120                      *sss_ele_cut &
4121                      *fac_shield(i)*fac_shield(j)
4122
4123 ! Diagnostics. Comment out or remove after debugging!
4124 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4125 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4126 !               ees0m(num_conti,i)=0.0D0
4127 ! End diagnostics.
4128 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4129 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4130 ! Angular derivatives of the contact function
4131                 ees0pij1=fac3/ees0pij
4132                 ees0mij1=fac3/ees0mij
4133                 fac3p=-3.0D0*fac3*rrmij
4134                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4135                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4136 !               ees0mij1=0.0D0
4137                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4138                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4139                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4140                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4141                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4142                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4143                 ecosap=ecosa1+ecosa2
4144                 ecosbp=ecosb1+ecosb2
4145                 ecosgp=ecosg1+ecosg2
4146                 ecosam=ecosa1-ecosa2
4147                 ecosbm=ecosb1-ecosb2
4148                 ecosgm=ecosg1-ecosg2
4149 ! Diagnostics
4150 !               ecosap=ecosa1
4151 !               ecosbp=ecosb1
4152 !               ecosgp=ecosg1
4153 !               ecosam=0.0D0
4154 !               ecosbm=0.0D0
4155 !               ecosgm=0.0D0
4156 ! End diagnostics
4157                 facont_hb(num_conti,i)=fcont
4158                 fprimcont=fprimcont/rij
4159 !d              facont_hb(num_conti,i)=1.0D0
4160 ! Following line is for diagnostics.
4161 !d              fprimcont=0.0D0
4162                 do k=1,3
4163                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4164                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4165                 enddo
4166                 do k=1,3
4167                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4168                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4169                 enddo
4170                 gggp(1)=gggp(1)+ees0pijp*xj &
4171                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4172                 gggp(2)=gggp(2)+ees0pijp*yj &
4173                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4174                 gggp(3)=gggp(3)+ees0pijp*zj &
4175                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4176
4177                 gggm(1)=gggm(1)+ees0mijp*xj &
4178                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4179
4180                 gggm(2)=gggm(2)+ees0mijp*yj &
4181                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4182
4183                 gggm(3)=gggm(3)+ees0mijp*zj &
4184                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4185
4186 ! Derivatives due to the contact function
4187                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4188                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4189                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4190                 do k=1,3
4191 !
4192 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4193 !          following the change of gradient-summation algorithm.
4194 !
4195 !grad                  ghalfp=0.5D0*gggp(k)
4196 !grad                  ghalfm=0.5D0*gggm(k)
4197                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4198                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4199                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4200                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4201
4202                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4203                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4204                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4205                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4206
4207                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4208                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4209
4210                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4211                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4212                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4213                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4214
4215                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4216                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4217                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4218                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4219
4220                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4221                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4222
4223                 enddo
4224 ! Diagnostics. Comment out or remove after debugging!
4225 !diag           do k=1,3
4226 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4227 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4228 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4229 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4230 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4231 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4232 !diag           enddo
4233               ENDIF ! wcorr
4234               endif  ! num_conti.le.maxconts
4235             endif  ! fcont.gt.0
4236           endif    ! j.gt.i+1
4237           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4238             do k=1,4
4239               do l=1,3
4240                 ghalf=0.5d0*agg(l,k)
4241                 aggi(l,k)=aggi(l,k)+ghalf
4242                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4243                 aggj(l,k)=aggj(l,k)+ghalf
4244               enddo
4245             enddo
4246             if (j.eq.nres-1 .and. i.lt.j-2) then
4247               do k=1,4
4248                 do l=1,3
4249                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4250                 enddo
4251               enddo
4252             endif
4253           endif
4254  128  continue
4255 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4256       return
4257       end subroutine eelecij
4258 !-----------------------------------------------------------------------------
4259       subroutine eturn3(i,eello_turn3)
4260 ! Third- and fourth-order contributions from turns
4261
4262       use comm_locel
4263 !      implicit real*8 (a-h,o-z)
4264 !      include 'DIMENSIONS'
4265 !      include 'COMMON.IOUNITS'
4266 !      include 'COMMON.GEO'
4267 !      include 'COMMON.VAR'
4268 !      include 'COMMON.LOCAL'
4269 !      include 'COMMON.CHAIN'
4270 !      include 'COMMON.DERIV'
4271 !      include 'COMMON.INTERACT'
4272 !      include 'COMMON.CONTACTS'
4273 !      include 'COMMON.TORSION'
4274 !      include 'COMMON.VECTORS'
4275 !      include 'COMMON.FFIELD'
4276 !      include 'COMMON.CONTROL'
4277       real(kind=8),dimension(3) :: ggg
4278       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4279         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4280       real(kind=8),dimension(2) :: auxvec,auxvec1
4281 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4282       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4283 !el      integer :: num_conti,j1,j2
4284 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4285 !el        dz_normi,xmedi,ymedi,zmedi
4286
4287 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4288 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4289 !el         num_conti,j1,j2
4290 !el local variables
4291       integer :: i,j,l,k,ilist,iresshield
4292       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4293
4294       j=i+2
4295 !      write (iout,*) "eturn3",i,j,j1,j2
4296           zj=(c(3,j)+c(3,j+1))/2.0d0
4297           zj=mod(zj,boxzsize)
4298           if (zj.lt.0) zj=zj+boxzsize
4299           if ((zj.lt.0)) write (*,*) "CHUJ"
4300        if ((zj.gt.bordlipbot)  &
4301         .and.(zj.lt.bordliptop)) then
4302 !C the energy transfer exist
4303         if (zj.lt.buflipbot) then
4304 !C what fraction I am in
4305          fracinbuf=1.0d0-     &
4306              ((zj-bordlipbot)/lipbufthick)
4307 !C lipbufthick is thickenes of lipid buffore
4308          sslipj=sscalelip(fracinbuf)
4309          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4310         elseif (zj.gt.bufliptop) then
4311          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4312          sslipj=sscalelip(fracinbuf)
4313          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4314         else
4315          sslipj=1.0d0
4316          ssgradlipj=0.0
4317         endif
4318        else
4319          sslipj=0.0d0
4320          ssgradlipj=0.0
4321        endif
4322
4323       a_temp(1,1)=a22
4324       a_temp(1,2)=a23
4325       a_temp(2,1)=a32
4326       a_temp(2,2)=a33
4327 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4328 !
4329 !               Third-order contributions
4330 !
4331 !                 (i+2)o----(i+3)
4332 !                      | |
4333 !                      | |
4334 !                 (i+1)o----i
4335 !
4336 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4337 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4338         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4339         call transpose2(auxmat(1,1),auxmat1(1,1))
4340         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4341         if (shield_mode.eq.0) then
4342         fac_shield(i)=1.0d0
4343         fac_shield(j)=1.0d0
4344         endif
4345
4346         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4347          *fac_shield(i)*fac_shield(j)  &
4348          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4349         eello_t3= &
4350         0.5d0*(pizda(1,1)+pizda(2,2)) &
4351         *fac_shield(i)*fac_shield(j)
4352
4353         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4354                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4355           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4356        (shield_mode.gt.0)) then
4357 !C          print *,i,j
4358
4359           do ilist=1,ishield_list(i)
4360            iresshield=shield_list(ilist,i)
4361            do k=1,3
4362            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4363            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4364                    rlocshield &
4365            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4366             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4367              +rlocshield
4368            enddo
4369           enddo
4370           do ilist=1,ishield_list(j)
4371            iresshield=shield_list(ilist,j)
4372            do k=1,3
4373            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4374            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4375                    rlocshield &
4376            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4377            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4378                   +rlocshield
4379
4380            enddo
4381           enddo
4382
4383           do k=1,3
4384             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4385                    grad_shield(k,i)*eello_t3/fac_shield(i)
4386             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4387                    grad_shield(k,j)*eello_t3/fac_shield(j)
4388             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4389                    grad_shield(k,i)*eello_t3/fac_shield(i)
4390             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4391                    grad_shield(k,j)*eello_t3/fac_shield(j)
4392            enddo
4393            endif
4394
4395 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4396 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4397 !d     &    ' eello_turn3_num',4*eello_turn3_num
4398 ! Derivatives in gamma(i)
4399         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4400         call transpose2(auxmat2(1,1),auxmat3(1,1))
4401         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4402         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4403           *fac_shield(i)*fac_shield(j)        &
4404           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4405 ! Derivatives in gamma(i+1)
4406         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4407         call transpose2(auxmat2(1,1),auxmat3(1,1))
4408         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4409         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4410           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4411           *fac_shield(i)*fac_shield(j)        &
4412           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4413
4414 ! Cartesian derivatives
4415         do l=1,3
4416 !            ghalf1=0.5d0*agg(l,1)
4417 !            ghalf2=0.5d0*agg(l,2)
4418 !            ghalf3=0.5d0*agg(l,3)
4419 !            ghalf4=0.5d0*agg(l,4)
4420           a_temp(1,1)=aggi(l,1)!+ghalf1
4421           a_temp(1,2)=aggi(l,2)!+ghalf2
4422           a_temp(2,1)=aggi(l,3)!+ghalf3
4423           a_temp(2,2)=aggi(l,4)!+ghalf4
4424           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4425           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4426             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4427           *fac_shield(i)*fac_shield(j)      &
4428           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4429
4430           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4431           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4432           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4433           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4434           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4435           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
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)=aggj(l,1)!+ghalf1
4441           a_temp(1,2)=aggj(l,2)!+ghalf2
4442           a_temp(2,1)=aggj(l,3)!+ghalf3
4443           a_temp(2,2)=aggj(l,4)!+ghalf4
4444           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4445           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
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)=aggj1(l,1)
4451           a_temp(1,2)=aggj1(l,2)
4452           a_temp(2,1)=aggj1(l,3)
4453           a_temp(2,2)=aggj1(l,4)
4454           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4455           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
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         enddo
4460          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4461           ssgradlipi*eello_t3/4.0d0*lipscale
4462          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4463           ssgradlipj*eello_t3/4.0d0*lipscale
4464          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4465           ssgradlipi*eello_t3/4.0d0*lipscale
4466          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4467           ssgradlipj*eello_t3/4.0d0*lipscale
4468
4469       return
4470       end subroutine eturn3
4471 !-----------------------------------------------------------------------------
4472       subroutine eturn4(i,eello_turn4)
4473 ! Third- and fourth-order contributions from turns
4474
4475       use comm_locel
4476 !      implicit real*8 (a-h,o-z)
4477 !      include 'DIMENSIONS'
4478 !      include 'COMMON.IOUNITS'
4479 !      include 'COMMON.GEO'
4480 !      include 'COMMON.VAR'
4481 !      include 'COMMON.LOCAL'
4482 !      include 'COMMON.CHAIN'
4483 !      include 'COMMON.DERIV'
4484 !      include 'COMMON.INTERACT'
4485 !      include 'COMMON.CONTACTS'
4486 !      include 'COMMON.TORSION'
4487 !      include 'COMMON.VECTORS'
4488 !      include 'COMMON.FFIELD'
4489 !      include 'COMMON.CONTROL'
4490       real(kind=8),dimension(3) :: ggg
4491       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4492         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4493       real(kind=8),dimension(2) :: auxvec,auxvec1
4494 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4495       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4496 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4497 !el        dz_normi,xmedi,ymedi,zmedi
4498 !el      integer :: num_conti,j1,j2
4499 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4500 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4501 !el          num_conti,j1,j2
4502 !el local variables
4503       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4504       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4505          rlocshield
4506
4507       j=i+3
4508 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4509 !
4510 !               Fourth-order contributions
4511 !
4512 !                 (i+3)o----(i+4)
4513 !                     /  |
4514 !               (i+2)o   |
4515 !                     \  |
4516 !                 (i+1)o----i
4517 !
4518 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4519 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4520 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4521           zj=(c(3,j)+c(3,j+1))/2.0d0
4522           zj=mod(zj,boxzsize)
4523           if (zj.lt.0) zj=zj+boxzsize
4524        if ((zj.gt.bordlipbot)  &
4525         .and.(zj.lt.bordliptop)) then
4526 !C the energy transfer exist
4527         if (zj.lt.buflipbot) then
4528 !C what fraction I am in
4529          fracinbuf=1.0d0-     &
4530              ((zj-bordlipbot)/lipbufthick)
4531 !C lipbufthick is thickenes of lipid buffore
4532          sslipj=sscalelip(fracinbuf)
4533          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4534         elseif (zj.gt.bufliptop) then
4535          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4536          sslipj=sscalelip(fracinbuf)
4537          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4538         else
4539          sslipj=1.0d0
4540          ssgradlipj=0.0
4541         endif
4542        else
4543          sslipj=0.0d0
4544          ssgradlipj=0.0
4545        endif
4546
4547         a_temp(1,1)=a22
4548         a_temp(1,2)=a23
4549         a_temp(2,1)=a32
4550         a_temp(2,2)=a33
4551         iti1=itortyp(itype(i+1,1))
4552         iti2=itortyp(itype(i+2,1))
4553         iti3=itortyp(itype(i+3,1))
4554 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4555         call transpose2(EUg(1,1,i+1),e1t(1,1))
4556         call transpose2(Eug(1,1,i+2),e2t(1,1))
4557         call transpose2(Eug(1,1,i+3),e3t(1,1))
4558         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4559         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4560         s1=scalar2(b1(1,iti2),auxvec(1))
4561         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4562         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4563         s2=scalar2(b1(1,iti1),auxvec(1))
4564         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4565         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4566         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4567         if (shield_mode.eq.0) then
4568         fac_shield(i)=1.0
4569         fac_shield(j)=1.0
4570         endif
4571
4572         eello_turn4=eello_turn4-(s1+s2+s3) &
4573         *fac_shield(i)*fac_shield(j)       &
4574         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4575         eello_t4=-(s1+s2+s3)  &
4576           *fac_shield(i)*fac_shield(j)
4577 !C Now derivative over shield:
4578           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4579          (shield_mode.gt.0)) then
4580 !C          print *,i,j
4581
4582           do ilist=1,ishield_list(i)
4583            iresshield=shield_list(ilist,i)
4584            do k=1,3
4585            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4586            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4587                    rlocshield &
4588             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4589             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4590            +rlocshield
4591            enddo
4592           enddo
4593           do ilist=1,ishield_list(j)
4594            iresshield=shield_list(ilist,j)
4595            do k=1,3
4596            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4597            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4598                    rlocshield  &
4599            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4600            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4601                   +rlocshield
4602
4603            enddo
4604           enddo
4605
4606           do k=1,3
4607             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4608                    grad_shield(k,i)*eello_t4/fac_shield(i)
4609             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4610                    grad_shield(k,j)*eello_t4/fac_shield(j)
4611             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4612                    grad_shield(k,i)*eello_t4/fac_shield(i)
4613             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4614                    grad_shield(k,j)*eello_t4/fac_shield(j)
4615            enddo
4616            endif
4617
4618         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4619            'eturn4',i,j,-(s1+s2+s3)
4620 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4621 !d     &    ' eello_turn4_num',8*eello_turn4_num
4622 ! Derivatives in gamma(i)
4623         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4624         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4625         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4626         s1=scalar2(b1(1,iti2),auxvec(1))
4627         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4628         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4629         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4630        *fac_shield(i)*fac_shield(j)  &
4631        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4632
4633 ! Derivatives in gamma(i+1)
4634         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4635         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4636         s2=scalar2(b1(1,iti1),auxvec(1))
4637         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4638         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4639         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4640         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4641        *fac_shield(i)*fac_shield(j)  &
4642        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4643
4644 ! Derivatives in gamma(i+2)
4645         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4646         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4647         s1=scalar2(b1(1,iti2),auxvec(1))
4648         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4649         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4650         s2=scalar2(b1(1,iti1),auxvec(1))
4651         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4652         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4653         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4654         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4655        *fac_shield(i)*fac_shield(j)  &
4656        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4657
4658 ! Cartesian derivatives
4659 ! Derivatives of this turn contributions in DC(i+2)
4660         if (j.lt.nres-1) then
4661           do l=1,3
4662             a_temp(1,1)=agg(l,1)
4663             a_temp(1,2)=agg(l,2)
4664             a_temp(2,1)=agg(l,3)
4665             a_temp(2,2)=agg(l,4)
4666             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4667             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4668             s1=scalar2(b1(1,iti2),auxvec(1))
4669             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4670             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4671             s2=scalar2(b1(1,iti1),auxvec(1))
4672             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4673             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4674             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4675             ggg(l)=-(s1+s2+s3)
4676             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4677        *fac_shield(i)*fac_shield(j)  &
4678        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4679
4680           enddo
4681         endif
4682 ! Remaining derivatives of this turn contribution
4683         do l=1,3
4684           a_temp(1,1)=aggi(l,1)
4685           a_temp(1,2)=aggi(l,2)
4686           a_temp(2,1)=aggi(l,3)
4687           a_temp(2,2)=aggi(l,4)
4688           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4689           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4690           s1=scalar2(b1(1,iti2),auxvec(1))
4691           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4692           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4693           s2=scalar2(b1(1,iti1),auxvec(1))
4694           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4695           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4696           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4697           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4698          *fac_shield(i)*fac_shield(j)  &
4699          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4700
4701
4702           a_temp(1,1)=aggi1(l,1)
4703           a_temp(1,2)=aggi1(l,2)
4704           a_temp(2,1)=aggi1(l,3)
4705           a_temp(2,2)=aggi1(l,4)
4706           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4707           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4708           s1=scalar2(b1(1,iti2),auxvec(1))
4709           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4710           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4711           s2=scalar2(b1(1,iti1),auxvec(1))
4712           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4713           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4714           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4715           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4716          *fac_shield(i)*fac_shield(j)  &
4717          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4718
4719
4720           a_temp(1,1)=aggj(l,1)
4721           a_temp(1,2)=aggj(l,2)
4722           a_temp(2,1)=aggj(l,3)
4723           a_temp(2,2)=aggj(l,4)
4724           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4725           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4726           s1=scalar2(b1(1,iti2),auxvec(1))
4727           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4728           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4729           s2=scalar2(b1(1,iti1),auxvec(1))
4730           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4731           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4732           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4733           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4734          *fac_shield(i)*fac_shield(j)  &
4735          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4736
4737
4738           a_temp(1,1)=aggj1(l,1)
4739           a_temp(1,2)=aggj1(l,2)
4740           a_temp(2,1)=aggj1(l,3)
4741           a_temp(2,2)=aggj1(l,4)
4742           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4743           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4744           s1=scalar2(b1(1,iti2),auxvec(1))
4745           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4746           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4747           s2=scalar2(b1(1,iti1),auxvec(1))
4748           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4749           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4750           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4751 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4752           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4753          *fac_shield(i)*fac_shield(j)  &
4754          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4755
4756         enddo
4757          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4758           ssgradlipi*eello_t4/4.0d0*lipscale
4759          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4760           ssgradlipj*eello_t4/4.0d0*lipscale
4761          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4762           ssgradlipi*eello_t4/4.0d0*lipscale
4763          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4764           ssgradlipj*eello_t4/4.0d0*lipscale
4765
4766       return
4767       end subroutine eturn4
4768 !-----------------------------------------------------------------------------
4769       subroutine unormderiv(u,ugrad,unorm,ungrad)
4770 ! This subroutine computes the derivatives of a normalized vector u, given
4771 ! the derivatives computed without normalization conditions, ugrad. Returns
4772 ! ungrad.
4773 !      implicit none
4774       real(kind=8),dimension(3) :: u,vec
4775       real(kind=8),dimension(3,3) ::ugrad,ungrad
4776       real(kind=8) :: unorm      !,scalar
4777       integer :: i,j
4778 !      write (2,*) 'ugrad',ugrad
4779 !      write (2,*) 'u',u
4780       do i=1,3
4781         vec(i)=scalar(ugrad(1,i),u(1))
4782       enddo
4783 !      write (2,*) 'vec',vec
4784       do i=1,3
4785         do j=1,3
4786           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4787         enddo
4788       enddo
4789 !      write (2,*) 'ungrad',ungrad
4790       return
4791       end subroutine unormderiv
4792 !-----------------------------------------------------------------------------
4793       subroutine escp_soft_sphere(evdw2,evdw2_14)
4794 !
4795 ! This subroutine calculates the excluded-volume interaction energy between
4796 ! peptide-group centers and side chains and its gradient in virtual-bond and
4797 ! side-chain vectors.
4798 !
4799 !      implicit real*8 (a-h,o-z)
4800 !      include 'DIMENSIONS'
4801 !      include 'COMMON.GEO'
4802 !      include 'COMMON.VAR'
4803 !      include 'COMMON.LOCAL'
4804 !      include 'COMMON.CHAIN'
4805 !      include 'COMMON.DERIV'
4806 !      include 'COMMON.INTERACT'
4807 !      include 'COMMON.FFIELD'
4808 !      include 'COMMON.IOUNITS'
4809 !      include 'COMMON.CONTROL'
4810       real(kind=8),dimension(3) :: ggg
4811 !el local variables
4812       integer :: i,iint,j,k,iteli,itypj
4813       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4814                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4815
4816       evdw2=0.0D0
4817       evdw2_14=0.0d0
4818       r0_scp=4.5d0
4819 !d    print '(a)','Enter ESCP'
4820 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4821       do i=iatscp_s,iatscp_e
4822         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4823         iteli=itel(i)
4824         xi=0.5D0*(c(1,i)+c(1,i+1))
4825         yi=0.5D0*(c(2,i)+c(2,i+1))
4826         zi=0.5D0*(c(3,i)+c(3,i+1))
4827
4828         do iint=1,nscp_gr(i)
4829
4830         do j=iscpstart(i,iint),iscpend(i,iint)
4831           if (itype(j,1).eq.ntyp1) cycle
4832           itypj=iabs(itype(j,1))
4833 ! Uncomment following three lines for SC-p interactions
4834 !         xj=c(1,nres+j)-xi
4835 !         yj=c(2,nres+j)-yi
4836 !         zj=c(3,nres+j)-zi
4837 ! Uncomment following three lines for Ca-p interactions
4838           xj=c(1,j)-xi
4839           yj=c(2,j)-yi
4840           zj=c(3,j)-zi
4841           rij=xj*xj+yj*yj+zj*zj
4842           r0ij=r0_scp
4843           r0ijsq=r0ij*r0ij
4844           if (rij.lt.r0ijsq) then
4845             evdwij=0.25d0*(rij-r0ijsq)**2
4846             fac=rij-r0ijsq
4847           else
4848             evdwij=0.0d0
4849             fac=0.0d0
4850           endif
4851           evdw2=evdw2+evdwij
4852 !
4853 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4854 !
4855           ggg(1)=xj*fac
4856           ggg(2)=yj*fac
4857           ggg(3)=zj*fac
4858 !grad          if (j.lt.i) then
4859 !d          write (iout,*) 'j<i'
4860 ! Uncomment following three lines for SC-p interactions
4861 !           do k=1,3
4862 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4863 !           enddo
4864 !grad          else
4865 !d          write (iout,*) 'j>i'
4866 !grad            do k=1,3
4867 !grad              ggg(k)=-ggg(k)
4868 ! Uncomment following line for SC-p interactions
4869 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4870 !grad            enddo
4871 !grad          endif
4872 !grad          do k=1,3
4873 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4874 !grad          enddo
4875 !grad          kstart=min0(i+1,j)
4876 !grad          kend=max0(i-1,j-1)
4877 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4878 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4879 !grad          do k=kstart,kend
4880 !grad            do l=1,3
4881 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4882 !grad            enddo
4883 !grad          enddo
4884           do k=1,3
4885             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4886             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4887           enddo
4888         enddo
4889
4890         enddo ! iint
4891       enddo ! i
4892       return
4893       end subroutine escp_soft_sphere
4894 !-----------------------------------------------------------------------------
4895       subroutine escp(evdw2,evdw2_14)
4896 !
4897 ! This subroutine calculates the excluded-volume interaction energy between
4898 ! peptide-group centers and side chains and its gradient in virtual-bond and
4899 ! side-chain vectors.
4900 !
4901 !      implicit real*8 (a-h,o-z)
4902 !      include 'DIMENSIONS'
4903 !      include 'COMMON.GEO'
4904 !      include 'COMMON.VAR'
4905 !      include 'COMMON.LOCAL'
4906 !      include 'COMMON.CHAIN'
4907 !      include 'COMMON.DERIV'
4908 !      include 'COMMON.INTERACT'
4909 !      include 'COMMON.FFIELD'
4910 !      include 'COMMON.IOUNITS'
4911 !      include 'COMMON.CONTROL'
4912       real(kind=8),dimension(3) :: ggg
4913 !el local variables
4914       integer :: i,iint,j,k,iteli,itypj,subchap
4915       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4916                    e1,e2,evdwij,rij
4917       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4918                     dist_temp, dist_init
4919       integer xshift,yshift,zshift
4920
4921       evdw2=0.0D0
4922       evdw2_14=0.0d0
4923 !d    print '(a)','Enter ESCP'
4924 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4925       do i=iatscp_s,iatscp_e
4926         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4927         iteli=itel(i)
4928         xi=0.5D0*(c(1,i)+c(1,i+1))
4929         yi=0.5D0*(c(2,i)+c(2,i+1))
4930         zi=0.5D0*(c(3,i)+c(3,i+1))
4931           xi=mod(xi,boxxsize)
4932           if (xi.lt.0) xi=xi+boxxsize
4933           yi=mod(yi,boxysize)
4934           if (yi.lt.0) yi=yi+boxysize
4935           zi=mod(zi,boxzsize)
4936           if (zi.lt.0) zi=zi+boxzsize
4937
4938         do iint=1,nscp_gr(i)
4939
4940         do j=iscpstart(i,iint),iscpend(i,iint)
4941           itypj=iabs(itype(j,1))
4942           if (itypj.eq.ntyp1) cycle
4943 ! Uncomment following three lines for SC-p interactions
4944 !         xj=c(1,nres+j)-xi
4945 !         yj=c(2,nres+j)-yi
4946 !         zj=c(3,nres+j)-zi
4947 ! Uncomment following three lines for Ca-p interactions
4948 !          xj=c(1,j)-xi
4949 !          yj=c(2,j)-yi
4950 !          zj=c(3,j)-zi
4951           xj=c(1,j)
4952           yj=c(2,j)
4953           zj=c(3,j)
4954           xj=mod(xj,boxxsize)
4955           if (xj.lt.0) xj=xj+boxxsize
4956           yj=mod(yj,boxysize)
4957           if (yj.lt.0) yj=yj+boxysize
4958           zj=mod(zj,boxzsize)
4959           if (zj.lt.0) zj=zj+boxzsize
4960       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4961       xj_safe=xj
4962       yj_safe=yj
4963       zj_safe=zj
4964       subchap=0
4965       do xshift=-1,1
4966       do yshift=-1,1
4967       do zshift=-1,1
4968           xj=xj_safe+xshift*boxxsize
4969           yj=yj_safe+yshift*boxysize
4970           zj=zj_safe+zshift*boxzsize
4971           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
4972           if(dist_temp.lt.dist_init) then
4973             dist_init=dist_temp
4974             xj_temp=xj
4975             yj_temp=yj
4976             zj_temp=zj
4977             subchap=1
4978           endif
4979        enddo
4980        enddo
4981        enddo
4982        if (subchap.eq.1) then
4983           xj=xj_temp-xi
4984           yj=yj_temp-yi
4985           zj=zj_temp-zi
4986        else
4987           xj=xj_safe-xi
4988           yj=yj_safe-yi
4989           zj=zj_safe-zi
4990        endif
4991
4992           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4993           rij=dsqrt(1.0d0/rrij)
4994             sss_ele_cut=sscale_ele(rij)
4995             sss_ele_grad=sscagrad_ele(rij)
4996 !            print *,sss_ele_cut,sss_ele_grad,&
4997 !            (rij),r_cut_ele,rlamb_ele
4998             if (sss_ele_cut.le.0.0) cycle
4999           fac=rrij**expon2
5000           e1=fac*fac*aad(itypj,iteli)
5001           e2=fac*bad(itypj,iteli)
5002           if (iabs(j-i) .le. 2) then
5003             e1=scal14*e1
5004             e2=scal14*e2
5005             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5006           endif
5007           evdwij=e1+e2
5008           evdw2=evdw2+evdwij*sss_ele_cut
5009 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5010 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5011           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5012              'evdw2',i,j,evdwij
5013 !
5014 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5015 !
5016           fac=-(evdwij+e1)*rrij*sss_ele_cut
5017           fac=fac+evdwij*sss_ele_grad/rij/expon
5018           ggg(1)=xj*fac
5019           ggg(2)=yj*fac
5020           ggg(3)=zj*fac
5021 !grad          if (j.lt.i) then
5022 !d          write (iout,*) 'j<i'
5023 ! Uncomment following three lines for SC-p interactions
5024 !           do k=1,3
5025 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5026 !           enddo
5027 !grad          else
5028 !d          write (iout,*) 'j>i'
5029 !grad            do k=1,3
5030 !grad              ggg(k)=-ggg(k)
5031 ! Uncomment following line for SC-p interactions
5032 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5033 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5034 !grad            enddo
5035 !grad          endif
5036 !grad          do k=1,3
5037 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5038 !grad          enddo
5039 !grad          kstart=min0(i+1,j)
5040 !grad          kend=max0(i-1,j-1)
5041 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5042 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5043 !grad          do k=kstart,kend
5044 !grad            do l=1,3
5045 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5046 !grad            enddo
5047 !grad          enddo
5048           do k=1,3
5049             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5050             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5051           enddo
5052         enddo
5053
5054         enddo ! iint
5055       enddo ! i
5056       do i=1,nct
5057         do j=1,3
5058           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5059           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5060           gradx_scp(j,i)=expon*gradx_scp(j,i)
5061         enddo
5062       enddo
5063 !******************************************************************************
5064 !
5065 !                              N O T E !!!
5066 !
5067 ! To save time the factor EXPON has been extracted from ALL components
5068 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5069 ! use!
5070 !
5071 !******************************************************************************
5072       return
5073       end subroutine escp
5074 !-----------------------------------------------------------------------------
5075       subroutine edis(ehpb)
5076 !
5077 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5078 !
5079 !      implicit real*8 (a-h,o-z)
5080 !      include 'DIMENSIONS'
5081 !      include 'COMMON.SBRIDGE'
5082 !      include 'COMMON.CHAIN'
5083 !      include 'COMMON.DERIV'
5084 !      include 'COMMON.VAR'
5085 !      include 'COMMON.INTERACT'
5086 !      include 'COMMON.IOUNITS'
5087       real(kind=8),dimension(3) :: ggg
5088 !el local variables
5089       integer :: i,j,ii,jj,iii,jjj,k
5090       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5091
5092       ehpb=0.0D0
5093 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5094 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5095       if (link_end.eq.0) return
5096       do i=link_start,link_end
5097 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5098 ! CA-CA distance used in regularization of structure.
5099         ii=ihpb(i)
5100         jj=jhpb(i)
5101 ! iii and jjj point to the residues for which the distance is assigned.
5102         if (ii.gt.nres) then
5103           iii=ii-nres
5104           jjj=jj-nres
5105         else
5106           iii=ii
5107           jjj=jj
5108         endif
5109 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5110 !     &    dhpb(i),dhpb1(i),forcon(i)
5111 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5112 !    distance and angle dependent SS bond potential.
5113 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5114 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5115         if (.not.dyn_ss .and. i.le.nss) then
5116 ! 15/02/13 CC dynamic SSbond - additional check
5117          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5118         iabs(itype(jjj,1)).eq.1) then
5119           call ssbond_ene(iii,jjj,eij)
5120           ehpb=ehpb+2*eij
5121 !d          write (iout,*) "eij",eij
5122          endif
5123         else if (ii.gt.nres .and. jj.gt.nres) then
5124 !c Restraints from contact prediction
5125           dd=dist(ii,jj)
5126           if (constr_dist.eq.11) then
5127             ehpb=ehpb+fordepth(i)**4.0d0 &
5128                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5129             fac=fordepth(i)**4.0d0 &
5130                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5131           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5132             ehpb,fordepth(i),dd
5133            else
5134           if (dhpb1(i).gt.0.0d0) then
5135             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5136             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5137 !c            write (iout,*) "beta nmr",
5138 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5139           else
5140             dd=dist(ii,jj)
5141             rdis=dd-dhpb(i)
5142 !C Get the force constant corresponding to this distance.
5143             waga=forcon(i)
5144 !C Calculate the contribution to energy.
5145             ehpb=ehpb+waga*rdis*rdis
5146 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5147 !C
5148 !C Evaluate gradient.
5149 !C
5150             fac=waga*rdis/dd
5151           endif
5152           endif
5153           do j=1,3
5154             ggg(j)=fac*(c(j,jj)-c(j,ii))
5155           enddo
5156           do j=1,3
5157             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5158             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5159           enddo
5160           do k=1,3
5161             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5162             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5163           enddo
5164         else
5165           dd=dist(ii,jj)
5166           if (constr_dist.eq.11) then
5167             ehpb=ehpb+fordepth(i)**4.0d0 &
5168                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5169             fac=fordepth(i)**4.0d0 &
5170                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5171           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5172          ehpb,fordepth(i),dd
5173            else
5174           if (dhpb1(i).gt.0.0d0) then
5175             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5176             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5177 !c            write (iout,*) "alph nmr",
5178 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5179           else
5180             rdis=dd-dhpb(i)
5181 !C Get the force constant corresponding to this distance.
5182             waga=forcon(i)
5183 !C Calculate the contribution to energy.
5184             ehpb=ehpb+waga*rdis*rdis
5185 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5186 !C
5187 !C Evaluate gradient.
5188 !C
5189             fac=waga*rdis/dd
5190           endif
5191           endif
5192
5193             do j=1,3
5194               ggg(j)=fac*(c(j,jj)-c(j,ii))
5195             enddo
5196 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5197 !C If this is a SC-SC distance, we need to calculate the contributions to the
5198 !C Cartesian gradient in the SC vectors (ghpbx).
5199           if (iii.lt.ii) then
5200           do j=1,3
5201             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5202             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5203           enddo
5204           endif
5205 !cgrad        do j=iii,jjj-1
5206 !cgrad          do k=1,3
5207 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5208 !cgrad          enddo
5209 !cgrad        enddo
5210           do k=1,3
5211             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5212             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5213           enddo
5214         endif
5215       enddo
5216       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5217
5218       return
5219       end subroutine edis
5220 !-----------------------------------------------------------------------------
5221       subroutine ssbond_ene(i,j,eij)
5222 !
5223 ! Calculate the distance and angle dependent SS-bond potential energy
5224 ! using a free-energy function derived based on RHF/6-31G** ab initio
5225 ! calculations of diethyl disulfide.
5226 !
5227 ! A. Liwo and U. Kozlowska, 11/24/03
5228 !
5229 !      implicit real*8 (a-h,o-z)
5230 !      include 'DIMENSIONS'
5231 !      include 'COMMON.SBRIDGE'
5232 !      include 'COMMON.CHAIN'
5233 !      include 'COMMON.DERIV'
5234 !      include 'COMMON.LOCAL'
5235 !      include 'COMMON.INTERACT'
5236 !      include 'COMMON.VAR'
5237 !      include 'COMMON.IOUNITS'
5238       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5239 !el local variables
5240       integer :: i,j,itypi,itypj,k
5241       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5242                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5243                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5244                    cosphi,ggk
5245
5246       itypi=iabs(itype(i,1))
5247       xi=c(1,nres+i)
5248       yi=c(2,nres+i)
5249       zi=c(3,nres+i)
5250       dxi=dc_norm(1,nres+i)
5251       dyi=dc_norm(2,nres+i)
5252       dzi=dc_norm(3,nres+i)
5253 !      dsci_inv=dsc_inv(itypi)
5254       dsci_inv=vbld_inv(nres+i)
5255       itypj=iabs(itype(j,1))
5256 !      dscj_inv=dsc_inv(itypj)
5257       dscj_inv=vbld_inv(nres+j)
5258       xj=c(1,nres+j)-xi
5259       yj=c(2,nres+j)-yi
5260       zj=c(3,nres+j)-zi
5261       dxj=dc_norm(1,nres+j)
5262       dyj=dc_norm(2,nres+j)
5263       dzj=dc_norm(3,nres+j)
5264       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5265       rij=dsqrt(rrij)
5266       erij(1)=xj*rij
5267       erij(2)=yj*rij
5268       erij(3)=zj*rij
5269       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5270       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5271       om12=dxi*dxj+dyi*dyj+dzi*dzj
5272       do k=1,3
5273         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5274         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5275       enddo
5276       rij=1.0d0/rij
5277       deltad=rij-d0cm
5278       deltat1=1.0d0-om1
5279       deltat2=1.0d0+om2
5280       deltat12=om2-om1+2.0d0
5281       cosphi=om12-om1*om2
5282       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5283         +akct*deltad*deltat12 &
5284         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5285 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5286 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5287 !     &  " deltat12",deltat12," eij",eij
5288       ed=2*akcm*deltad+akct*deltat12
5289       pom1=akct*deltad
5290       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5291       eom1=-2*akth*deltat1-pom1-om2*pom2
5292       eom2= 2*akth*deltat2+pom1-om1*pom2
5293       eom12=pom2
5294       do k=1,3
5295         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5296         ghpbx(k,i)=ghpbx(k,i)-ggk &
5297                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5298                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5299         ghpbx(k,j)=ghpbx(k,j)+ggk &
5300                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5301                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5302         ghpbc(k,i)=ghpbc(k,i)-ggk
5303         ghpbc(k,j)=ghpbc(k,j)+ggk
5304       enddo
5305 !
5306 ! Calculate the components of the gradient in DC and X
5307 !
5308 !grad      do k=i,j-1
5309 !grad        do l=1,3
5310 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5311 !grad        enddo
5312 !grad      enddo
5313       return
5314       end subroutine ssbond_ene
5315 !-----------------------------------------------------------------------------
5316       subroutine ebond(estr)
5317 !
5318 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5319 !
5320 !      implicit real*8 (a-h,o-z)
5321 !      include 'DIMENSIONS'
5322 !      include 'COMMON.LOCAL'
5323 !      include 'COMMON.GEO'
5324 !      include 'COMMON.INTERACT'
5325 !      include 'COMMON.DERIV'
5326 !      include 'COMMON.VAR'
5327 !      include 'COMMON.CHAIN'
5328 !      include 'COMMON.IOUNITS'
5329 !      include 'COMMON.NAMES'
5330 !      include 'COMMON.FFIELD'
5331 !      include 'COMMON.CONTROL'
5332 !      include 'COMMON.SETUP'
5333       real(kind=8),dimension(3) :: u,ud
5334 !el local variables
5335       integer :: i,j,iti,nbi,k
5336       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5337                    uprod1,uprod2
5338
5339       estr=0.0d0
5340       estr1=0.0d0
5341 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5342 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5343
5344       do i=ibondp_start,ibondp_end
5345         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5346         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5347 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5348 !C          do j=1,3
5349 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5350 !C            *dc(j,i-1)/vbld(i)
5351 !C          enddo
5352 !C          if (energy_dec) write(iout,*) &
5353 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5354         diff = vbld(i)-vbldpDUM
5355         else
5356         diff = vbld(i)-vbldp0
5357         endif
5358         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5359            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5360         estr=estr+diff*diff
5361         do j=1,3
5362           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5363         enddo
5364 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5365 !        endif
5366       enddo
5367       estr=0.5d0*AKP*estr+estr1
5368 !      print *,"estr_bb",estr,AKP
5369 !
5370 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5371 !
5372       do i=ibond_start,ibond_end
5373         iti=iabs(itype(i,1))
5374         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5375         if (iti.ne.10 .and. iti.ne.ntyp1) then
5376           nbi=nbondterm(iti)
5377           if (nbi.eq.1) then
5378             diff=vbld(i+nres)-vbldsc0(1,iti)
5379             if (energy_dec) write (iout,*) &
5380             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5381             AKSC(1,iti),AKSC(1,iti)*diff*diff
5382             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5383 !            print *,"estr_sc",estr
5384             do j=1,3
5385               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5386             enddo
5387           else
5388             do j=1,nbi
5389               diff=vbld(i+nres)-vbldsc0(j,iti)
5390               ud(j)=aksc(j,iti)*diff
5391               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5392             enddo
5393             uprod=u(1)
5394             do j=2,nbi
5395               uprod=uprod*u(j)
5396             enddo
5397             usum=0.0d0
5398             usumsqder=0.0d0
5399             do j=1,nbi
5400               uprod1=1.0d0
5401               uprod2=1.0d0
5402               do k=1,nbi
5403                 if (k.ne.j) then
5404                   uprod1=uprod1*u(k)
5405                   uprod2=uprod2*u(k)*u(k)
5406                 endif
5407               enddo
5408               usum=usum+uprod1
5409               usumsqder=usumsqder+ud(j)*uprod2
5410             enddo
5411             estr=estr+uprod/usum
5412 !            print *,"estr_sc",estr,i
5413
5414              if (energy_dec) write (iout,*) &
5415             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5416             AKSC(1,iti),uprod/usum
5417             do j=1,3
5418              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5419             enddo
5420           endif
5421         endif
5422       enddo
5423       return
5424       end subroutine ebond
5425 #ifdef CRYST_THETA
5426 !-----------------------------------------------------------------------------
5427       subroutine ebend(etheta)
5428 !
5429 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5430 ! angles gamma and its derivatives in consecutive thetas and gammas.
5431 !
5432       use comm_calcthet
5433 !      implicit real*8 (a-h,o-z)
5434 !      include 'DIMENSIONS'
5435 !      include 'COMMON.LOCAL'
5436 !      include 'COMMON.GEO'
5437 !      include 'COMMON.INTERACT'
5438 !      include 'COMMON.DERIV'
5439 !      include 'COMMON.VAR'
5440 !      include 'COMMON.CHAIN'
5441 !      include 'COMMON.IOUNITS'
5442 !      include 'COMMON.NAMES'
5443 !      include 'COMMON.FFIELD'
5444 !      include 'COMMON.CONTROL'
5445 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5446 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5447 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5448 !el      integer :: it
5449 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5450 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5451 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5452 !el local variables
5453       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5454        ichir21,ichir22
5455       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5456        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5457        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5458       real(kind=8),dimension(2) :: y,z
5459
5460       delta=0.02d0*pi
5461 !      time11=dexp(-2*time)
5462 !      time12=1.0d0
5463       etheta=0.0D0
5464 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5465       do i=ithet_start,ithet_end
5466         if (itype(i-1,1).eq.ntyp1) cycle
5467 ! Zero the energy function and its derivative at 0 or pi.
5468         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5469         it=itype(i-1,1)
5470         ichir1=isign(1,itype(i-2,1))
5471         ichir2=isign(1,itype(i,1))
5472          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5473          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5474          if (itype(i-1,1).eq.10) then
5475           itype1=isign(10,itype(i-2,1))
5476           ichir11=isign(1,itype(i-2,1))
5477           ichir12=isign(1,itype(i-2,1))
5478           itype2=isign(10,itype(i,1))
5479           ichir21=isign(1,itype(i,1))
5480           ichir22=isign(1,itype(i,1))
5481          endif
5482
5483         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5484 #ifdef OSF
5485           phii=phi(i)
5486           if (phii.ne.phii) phii=150.0
5487 #else
5488           phii=phi(i)
5489 #endif
5490           y(1)=dcos(phii)
5491           y(2)=dsin(phii)
5492         else
5493           y(1)=0.0D0
5494           y(2)=0.0D0
5495         endif
5496         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5497 #ifdef OSF
5498           phii1=phi(i+1)
5499           if (phii1.ne.phii1) phii1=150.0
5500           phii1=pinorm(phii1)
5501           z(1)=cos(phii1)
5502 #else
5503           phii1=phi(i+1)
5504           z(1)=dcos(phii1)
5505 #endif
5506           z(2)=dsin(phii1)
5507         else
5508           z(1)=0.0D0
5509           z(2)=0.0D0
5510         endif
5511 ! Calculate the "mean" value of theta from the part of the distribution
5512 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5513 ! In following comments this theta will be referred to as t_c.
5514         thet_pred_mean=0.0d0
5515         do k=1,2
5516             athetk=athet(k,it,ichir1,ichir2)
5517             bthetk=bthet(k,it,ichir1,ichir2)
5518           if (it.eq.10) then
5519              athetk=athet(k,itype1,ichir11,ichir12)
5520              bthetk=bthet(k,itype2,ichir21,ichir22)
5521           endif
5522          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5523         enddo
5524         dthett=thet_pred_mean*ssd
5525         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5526 ! Derivatives of the "mean" values in gamma1 and gamma2.
5527         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5528                +athet(2,it,ichir1,ichir2)*y(1))*ss
5529         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5530                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5531          if (it.eq.10) then
5532         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5533              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5534         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5535                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5536          endif
5537         if (theta(i).gt.pi-delta) then
5538           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5539                E_tc0)
5540           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5541           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5542           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5543               E_theta)
5544           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5545               E_tc)
5546         else if (theta(i).lt.delta) then
5547           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5548           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5549           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5550               E_theta)
5551           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5552           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5553               E_tc)
5554         else
5555           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5556               E_theta,E_tc)
5557         endif
5558         etheta=etheta+ethetai
5559         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5560             'ebend',i,ethetai
5561         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5562         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5563         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5564       enddo
5565 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5566
5567 ! Ufff.... We've done all this!!!
5568       return
5569       end subroutine ebend
5570 !-----------------------------------------------------------------------------
5571       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5572
5573       use comm_calcthet
5574 !      implicit real*8 (a-h,o-z)
5575 !      include 'DIMENSIONS'
5576 !      include 'COMMON.LOCAL'
5577 !      include 'COMMON.IOUNITS'
5578 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5579 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5580 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5581       integer :: i,j,k
5582       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5583 !el      integer :: it
5584 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5585 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5586 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5587 !el local variables
5588       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5589        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5590
5591 ! Calculate the contributions to both Gaussian lobes.
5592 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5593 ! The "polynomial part" of the "standard deviation" of this part of
5594 ! the distribution.
5595         sig=polthet(3,it)
5596         do j=2,0,-1
5597           sig=sig*thet_pred_mean+polthet(j,it)
5598         enddo
5599 ! Derivative of the "interior part" of the "standard deviation of the"
5600 ! gamma-dependent Gaussian lobe in t_c.
5601         sigtc=3*polthet(3,it)
5602         do j=2,1,-1
5603           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5604         enddo
5605         sigtc=sig*sigtc
5606 ! Set the parameters of both Gaussian lobes of the distribution.
5607 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5608         fac=sig*sig+sigc0(it)
5609         sigcsq=fac+fac
5610         sigc=1.0D0/sigcsq
5611 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5612         sigsqtc=-4.0D0*sigcsq*sigtc
5613 !       print *,i,sig,sigtc,sigsqtc
5614 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5615         sigtc=-sigtc/(fac*fac)
5616 ! Following variable is sigma(t_c)**(-2)
5617         sigcsq=sigcsq*sigcsq
5618         sig0i=sig0(it)
5619         sig0inv=1.0D0/sig0i**2
5620         delthec=thetai-thet_pred_mean
5621         delthe0=thetai-theta0i
5622         term1=-0.5D0*sigcsq*delthec*delthec
5623         term2=-0.5D0*sig0inv*delthe0*delthe0
5624 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5625 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5626 ! to the energy (this being the log of the distribution) at the end of energy
5627 ! term evaluation for this virtual-bond angle.
5628         if (term1.gt.term2) then
5629           termm=term1
5630           term2=dexp(term2-termm)
5631           term1=1.0d0
5632         else
5633           termm=term2
5634           term1=dexp(term1-termm)
5635           term2=1.0d0
5636         endif
5637 ! The ratio between the gamma-independent and gamma-dependent lobes of
5638 ! the distribution is a Gaussian function of thet_pred_mean too.
5639         diffak=gthet(2,it)-thet_pred_mean
5640         ratak=diffak/gthet(3,it)**2
5641         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5642 ! Let's differentiate it in thet_pred_mean NOW.
5643         aktc=ak*ratak
5644 ! Now put together the distribution terms to make complete distribution.
5645         termexp=term1+ak*term2
5646         termpre=sigc+ak*sig0i
5647 ! Contribution of the bending energy from this theta is just the -log of
5648 ! the sum of the contributions from the two lobes and the pre-exponential
5649 ! factor. Simple enough, isn't it?
5650         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5651 ! NOW the derivatives!!!
5652 ! 6/6/97 Take into account the deformation.
5653         E_theta=(delthec*sigcsq*term1 &
5654              +ak*delthe0*sig0inv*term2)/termexp
5655         E_tc=((sigtc+aktc*sig0i)/termpre &
5656             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5657              aktc*term2)/termexp)
5658       return
5659       end subroutine theteng
5660 #else
5661 !-----------------------------------------------------------------------------
5662       subroutine ebend(etheta,ethetacnstr)
5663 !
5664 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5665 ! angles gamma and its derivatives in consecutive thetas and gammas.
5666 ! ab initio-derived potentials from
5667 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5668 !
5669 !      implicit real*8 (a-h,o-z)
5670 !      include 'DIMENSIONS'
5671 !      include 'COMMON.LOCAL'
5672 !      include 'COMMON.GEO'
5673 !      include 'COMMON.INTERACT'
5674 !      include 'COMMON.DERIV'
5675 !      include 'COMMON.VAR'
5676 !      include 'COMMON.CHAIN'
5677 !      include 'COMMON.IOUNITS'
5678 !      include 'COMMON.NAMES'
5679 !      include 'COMMON.FFIELD'
5680 !      include 'COMMON.CONTROL'
5681       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5682       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5683       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5684       logical :: lprn=.false., lprn1=.false.
5685 !el local variables
5686       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5687       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5688       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5689 ! local variables for constrains
5690       real(kind=8) :: difi,thetiii
5691        integer itheta
5692
5693       etheta=0.0D0
5694       do i=ithet_start,ithet_end
5695         if (itype(i-1,1).eq.ntyp1) cycle
5696         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5697         if (iabs(itype(i+1,1)).eq.20) iblock=2
5698         if (iabs(itype(i+1,1)).ne.20) iblock=1
5699         dethetai=0.0d0
5700         dephii=0.0d0
5701         dephii1=0.0d0
5702         theti2=0.5d0*theta(i)
5703         ityp2=ithetyp((itype(i-1,1)))
5704         do k=1,nntheterm
5705           coskt(k)=dcos(k*theti2)
5706           sinkt(k)=dsin(k*theti2)
5707         enddo
5708         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5709 #ifdef OSF
5710           phii=phi(i)
5711           if (phii.ne.phii) phii=150.0
5712 #else
5713           phii=phi(i)
5714 #endif
5715           ityp1=ithetyp((itype(i-2,1)))
5716 ! propagation of chirality for glycine type
5717           do k=1,nsingle
5718             cosph1(k)=dcos(k*phii)
5719             sinph1(k)=dsin(k*phii)
5720           enddo
5721         else
5722           phii=0.0d0
5723           ityp1=ithetyp(itype(i-2,1))
5724           do k=1,nsingle
5725             cosph1(k)=0.0d0
5726             sinph1(k)=0.0d0
5727           enddo
5728         endif
5729         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5730 #ifdef OSF
5731           phii1=phi(i+1)
5732           if (phii1.ne.phii1) phii1=150.0
5733           phii1=pinorm(phii1)
5734 #else
5735           phii1=phi(i+1)
5736 #endif
5737           ityp3=ithetyp((itype(i,1)))
5738           do k=1,nsingle
5739             cosph2(k)=dcos(k*phii1)
5740             sinph2(k)=dsin(k*phii1)
5741           enddo
5742         else
5743           phii1=0.0d0
5744           ityp3=ithetyp(itype(i,1))
5745           do k=1,nsingle
5746             cosph2(k)=0.0d0
5747             sinph2(k)=0.0d0
5748           enddo
5749         endif
5750         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5751         do k=1,ndouble
5752           do l=1,k-1
5753             ccl=cosph1(l)*cosph2(k-l)
5754             ssl=sinph1(l)*sinph2(k-l)
5755             scl=sinph1(l)*cosph2(k-l)
5756             csl=cosph1(l)*sinph2(k-l)
5757             cosph1ph2(l,k)=ccl-ssl
5758             cosph1ph2(k,l)=ccl+ssl
5759             sinph1ph2(l,k)=scl+csl
5760             sinph1ph2(k,l)=scl-csl
5761           enddo
5762         enddo
5763         if (lprn) then
5764         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5765           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5766         write (iout,*) "coskt and sinkt"
5767         do k=1,nntheterm
5768           write (iout,*) k,coskt(k),sinkt(k)
5769         enddo
5770         endif
5771         do k=1,ntheterm
5772           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5773           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5774             *coskt(k)
5775           if (lprn) &
5776           write (iout,*) "k",k,&
5777            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5778            " ethetai",ethetai
5779         enddo
5780         if (lprn) then
5781         write (iout,*) "cosph and sinph"
5782         do k=1,nsingle
5783           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5784         enddo
5785         write (iout,*) "cosph1ph2 and sinph2ph2"
5786         do k=2,ndouble
5787           do l=1,k-1
5788             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5789                sinph1ph2(l,k),sinph1ph2(k,l)
5790           enddo
5791         enddo
5792         write(iout,*) "ethetai",ethetai
5793         endif
5794         do m=1,ntheterm2
5795           do k=1,nsingle
5796             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5797                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5798                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5799                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5800             ethetai=ethetai+sinkt(m)*aux
5801             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5802             dephii=dephii+k*sinkt(m)* &
5803                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5804                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5805             dephii1=dephii1+k*sinkt(m)* &
5806                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5807                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5808             if (lprn) &
5809             write (iout,*) "m",m," k",k," bbthet", &
5810                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5811                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5812                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5813                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5814           enddo
5815         enddo
5816         if (lprn) &
5817         write(iout,*) "ethetai",ethetai
5818         do m=1,ntheterm3
5819           do k=2,ndouble
5820             do l=1,k-1
5821               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5822                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5823                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5824                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5825               ethetai=ethetai+sinkt(m)*aux
5826               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5827               dephii=dephii+l*sinkt(m)* &
5828                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5829                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5830                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5831                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5832               dephii1=dephii1+(k-l)*sinkt(m)* &
5833                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5834                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5835                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5836                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5837               if (lprn) then
5838               write (iout,*) "m",m," k",k," l",l," ffthet",&
5839                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5840                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5841                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5842                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5843                   " ethetai",ethetai
5844               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5845                   cosph1ph2(k,l)*sinkt(m),&
5846                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5847               endif
5848             enddo
5849           enddo
5850         enddo
5851 10      continue
5852 !        lprn1=.true.
5853         if (lprn1) &
5854           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5855          i,theta(i)*rad2deg,phii*rad2deg,&
5856          phii1*rad2deg,ethetai
5857 !        lprn1=.false.
5858         etheta=etheta+ethetai
5859         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5860                                     'ebend',i,ethetai
5861         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5862         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5863         gloc(nphi+i-2,icg)=wang*dethetai
5864       enddo
5865 !-----------thete constrains
5866 !      if (tor_mode.ne.2) then
5867       ethetacnstr=0.0d0
5868 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5869       do i=ithetaconstr_start,ithetaconstr_end
5870         itheta=itheta_constr(i)
5871         thetiii=theta(itheta)
5872         difi=pinorm(thetiii-theta_constr0(i))
5873         if (difi.gt.theta_drange(i)) then
5874           difi=difi-theta_drange(i)
5875           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5876           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5877          +for_thet_constr(i)*difi**3
5878         else if (difi.lt.-drange(i)) then
5879           difi=difi+drange(i)
5880           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5881           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5882          +for_thet_constr(i)*difi**3
5883         else
5884           difi=0.0
5885         endif
5886        if (energy_dec) then
5887         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5888          i,itheta,rad2deg*thetiii, &
5889          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5890          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5891          gloc(itheta+nphi-2,icg)
5892         endif
5893       enddo
5894 !      endif
5895
5896       return
5897       end subroutine ebend
5898 #endif
5899 #ifdef CRYST_SC
5900 !-----------------------------------------------------------------------------
5901       subroutine esc(escloc)
5902 ! Calculate the local energy of a side chain and its derivatives in the
5903 ! corresponding virtual-bond valence angles THETA and the spherical angles
5904 ! ALPHA and OMEGA.
5905 !
5906       use comm_sccalc
5907 !      implicit real*8 (a-h,o-z)
5908 !      include 'DIMENSIONS'
5909 !      include 'COMMON.GEO'
5910 !      include 'COMMON.LOCAL'
5911 !      include 'COMMON.VAR'
5912 !      include 'COMMON.INTERACT'
5913 !      include 'COMMON.DERIV'
5914 !      include 'COMMON.CHAIN'
5915 !      include 'COMMON.IOUNITS'
5916 !      include 'COMMON.NAMES'
5917 !      include 'COMMON.FFIELD'
5918 !      include 'COMMON.CONTROL'
5919       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5920          ddersc0,ddummy,xtemp,temp
5921 !el      real(kind=8) :: time11,time12,time112,theti
5922       real(kind=8) :: escloc,delta
5923 !el      integer :: it,nlobit
5924 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5925 !el local variables
5926       integer :: i,k
5927       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5928        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5929       delta=0.02d0*pi
5930       escloc=0.0D0
5931 !     write (iout,'(a)') 'ESC'
5932       do i=loc_start,loc_end
5933         it=itype(i,1)
5934         if (it.eq.ntyp1) cycle
5935         if (it.eq.10) goto 1
5936         nlobit=nlob(iabs(it))
5937 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5938 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5939         theti=theta(i+1)-pipol
5940         x(1)=dtan(theti)
5941         x(2)=alph(i)
5942         x(3)=omeg(i)
5943
5944         if (x(2).gt.pi-delta) then
5945           xtemp(1)=x(1)
5946           xtemp(2)=pi-delta
5947           xtemp(3)=x(3)
5948           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5949           xtemp(2)=pi
5950           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5951           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
5952               escloci,dersc(2))
5953           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5954               ddersc0(1),dersc(1))
5955           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
5956               ddersc0(3),dersc(3))
5957           xtemp(2)=pi-delta
5958           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5959           xtemp(2)=pi
5960           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5961           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
5962                   dersc0(2),esclocbi,dersc02)
5963           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
5964                   dersc12,dersc01)
5965           call splinthet(x(2),0.5d0*delta,ss,ssd)
5966           dersc0(1)=dersc01
5967           dersc0(2)=dersc02
5968           dersc0(3)=0.0d0
5969           do k=1,3
5970             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5971           enddo
5972           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5973 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5974 !    &             esclocbi,ss,ssd
5975           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5976 !         escloci=esclocbi
5977 !         write (iout,*) escloci
5978         else if (x(2).lt.delta) then
5979           xtemp(1)=x(1)
5980           xtemp(2)=delta
5981           xtemp(3)=x(3)
5982           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5983           xtemp(2)=0.0d0
5984           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5985           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
5986               escloci,dersc(2))
5987           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5988               ddersc0(1),dersc(1))
5989           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
5990               ddersc0(3),dersc(3))
5991           xtemp(2)=delta
5992           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5993           xtemp(2)=0.0d0
5994           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5995           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
5996                   dersc0(2),esclocbi,dersc02)
5997           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
5998                   dersc12,dersc01)
5999           dersc0(1)=dersc01
6000           dersc0(2)=dersc02
6001           dersc0(3)=0.0d0
6002           call splinthet(x(2),0.5d0*delta,ss,ssd)
6003           do k=1,3
6004             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6005           enddo
6006           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6007 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6008 !    &             esclocbi,ss,ssd
6009           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6010 !         write (iout,*) escloci
6011         else
6012           call enesc(x,escloci,dersc,ddummy,.false.)
6013         endif
6014
6015         escloc=escloc+escloci
6016         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6017            'escloc',i,escloci
6018 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6019
6020         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6021          wscloc*dersc(1)
6022         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6023         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6024     1   continue
6025       enddo
6026       return
6027       end subroutine esc
6028 !-----------------------------------------------------------------------------
6029       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6030
6031       use comm_sccalc
6032 !      implicit real*8 (a-h,o-z)
6033 !      include 'DIMENSIONS'
6034 !      include 'COMMON.GEO'
6035 !      include 'COMMON.LOCAL'
6036 !      include 'COMMON.IOUNITS'
6037 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6038       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6039       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6040       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6041       real(kind=8) :: escloci
6042       logical :: mixed
6043 !el local variables
6044       integer :: j,iii,l,k !el,it,nlobit
6045       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6046 !el       time11,time12,time112
6047 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6048         escloc_i=0.0D0
6049         do j=1,3
6050           dersc(j)=0.0D0
6051           if (mixed) ddersc(j)=0.0d0
6052         enddo
6053         x3=x(3)
6054
6055 ! Because of periodicity of the dependence of the SC energy in omega we have
6056 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6057 ! To avoid underflows, first compute & store the exponents.
6058
6059         do iii=-1,1
6060
6061           x(3)=x3+iii*dwapi
6062
6063           do j=1,nlobit
6064             do k=1,3
6065               z(k)=x(k)-censc(k,j,it)
6066             enddo
6067             do k=1,3
6068               Axk=0.0D0
6069               do l=1,3
6070                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6071               enddo
6072               Ax(k,j,iii)=Axk
6073             enddo
6074             expfac=0.0D0
6075             do k=1,3
6076               expfac=expfac+Ax(k,j,iii)*z(k)
6077             enddo
6078             contr(j,iii)=expfac
6079           enddo ! j
6080
6081         enddo ! iii
6082
6083         x(3)=x3
6084 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6085 ! subsequent NaNs and INFs in energy calculation.
6086 ! Find the largest exponent
6087         emin=contr(1,-1)
6088         do iii=-1,1
6089           do j=1,nlobit
6090             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6091           enddo
6092         enddo
6093         emin=0.5D0*emin
6094 !d      print *,'it=',it,' emin=',emin
6095
6096 ! Compute the contribution to SC energy and derivatives
6097         do iii=-1,1
6098
6099           do j=1,nlobit
6100 #ifdef OSF
6101             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6102             if(adexp.ne.adexp) adexp=1.0
6103             expfac=dexp(adexp)
6104 #else
6105             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6106 #endif
6107 !d          print *,'j=',j,' expfac=',expfac
6108             escloc_i=escloc_i+expfac
6109             do k=1,3
6110               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6111             enddo
6112             if (mixed) then
6113               do k=1,3,2
6114                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6115                   +gaussc(k,2,j,it))*expfac
6116               enddo
6117             endif
6118           enddo
6119
6120         enddo ! iii
6121
6122         dersc(1)=dersc(1)/cos(theti)**2
6123         ddersc(1)=ddersc(1)/cos(theti)**2
6124         ddersc(3)=ddersc(3)
6125
6126         escloci=-(dlog(escloc_i)-emin)
6127         do j=1,3
6128           dersc(j)=dersc(j)/escloc_i
6129         enddo
6130         if (mixed) then
6131           do j=1,3,2
6132             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6133           enddo
6134         endif
6135       return
6136       end subroutine enesc
6137 !-----------------------------------------------------------------------------
6138       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6139
6140       use comm_sccalc
6141 !      implicit real*8 (a-h,o-z)
6142 !      include 'DIMENSIONS'
6143 !      include 'COMMON.GEO'
6144 !      include 'COMMON.LOCAL'
6145 !      include 'COMMON.IOUNITS'
6146 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6147       real(kind=8),dimension(3) :: x,z,dersc
6148       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6149       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6150       real(kind=8) :: escloci,dersc12,emin
6151       logical :: mixed
6152 !el local varables
6153       integer :: j,k,l !el,it,nlobit
6154       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6155
6156       escloc_i=0.0D0
6157
6158       do j=1,3
6159         dersc(j)=0.0D0
6160       enddo
6161
6162       do j=1,nlobit
6163         do k=1,2
6164           z(k)=x(k)-censc(k,j,it)
6165         enddo
6166         z(3)=dwapi
6167         do k=1,3
6168           Axk=0.0D0
6169           do l=1,3
6170             Axk=Axk+gaussc(l,k,j,it)*z(l)
6171           enddo
6172           Ax(k,j)=Axk
6173         enddo
6174         expfac=0.0D0
6175         do k=1,3
6176           expfac=expfac+Ax(k,j)*z(k)
6177         enddo
6178         contr(j)=expfac
6179       enddo ! j
6180
6181 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6182 ! subsequent NaNs and INFs in energy calculation.
6183 ! Find the largest exponent
6184       emin=contr(1)
6185       do j=1,nlobit
6186         if (emin.gt.contr(j)) emin=contr(j)
6187       enddo
6188       emin=0.5D0*emin
6189
6190 ! Compute the contribution to SC energy and derivatives
6191
6192       dersc12=0.0d0
6193       do j=1,nlobit
6194         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6195         escloc_i=escloc_i+expfac
6196         do k=1,2
6197           dersc(k)=dersc(k)+Ax(k,j)*expfac
6198         enddo
6199         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6200                   +gaussc(1,2,j,it))*expfac
6201         dersc(3)=0.0d0
6202       enddo
6203
6204       dersc(1)=dersc(1)/cos(theti)**2
6205       dersc12=dersc12/cos(theti)**2
6206       escloci=-(dlog(escloc_i)-emin)
6207       do j=1,2
6208         dersc(j)=dersc(j)/escloc_i
6209       enddo
6210       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6211       return
6212       end subroutine enesc_bound
6213 #else
6214 !-----------------------------------------------------------------------------
6215       subroutine esc(escloc)
6216 ! Calculate the local energy of a side chain and its derivatives in the
6217 ! corresponding virtual-bond valence angles THETA and the spherical angles
6218 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6219 ! added by Urszula Kozlowska. 07/11/2007
6220 !
6221       use comm_sccalc
6222 !      implicit real*8 (a-h,o-z)
6223 !      include 'DIMENSIONS'
6224 !      include 'COMMON.GEO'
6225 !      include 'COMMON.LOCAL'
6226 !      include 'COMMON.VAR'
6227 !      include 'COMMON.SCROT'
6228 !      include 'COMMON.INTERACT'
6229 !      include 'COMMON.DERIV'
6230 !      include 'COMMON.CHAIN'
6231 !      include 'COMMON.IOUNITS'
6232 !      include 'COMMON.NAMES'
6233 !      include 'COMMON.FFIELD'
6234 !      include 'COMMON.CONTROL'
6235 !      include 'COMMON.VECTORS'
6236       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6237       real(kind=8),dimension(65) :: x
6238       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6239          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6240       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6241       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6242          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6243 !el local variables
6244       integer :: i,j,k !el,it,nlobit
6245       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6246 !el      real(kind=8) :: time11,time12,time112,theti
6247 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6248       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6249                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6250                    sumene1x,sumene2x,sumene3x,sumene4x,&
6251                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6252                    cosfac2xx,sinfac2yy
6253 #ifdef DEBUG
6254       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6255                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6256                    de_dt_num
6257 #endif
6258 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6259
6260       delta=0.02d0*pi
6261       escloc=0.0D0
6262       do i=loc_start,loc_end
6263         if (itype(i,1).eq.ntyp1) cycle
6264         costtab(i+1) =dcos(theta(i+1))
6265         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6266         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6267         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6268         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6269         cosfac=dsqrt(cosfac2)
6270         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6271         sinfac=dsqrt(sinfac2)
6272         it=iabs(itype(i,1))
6273         if (it.eq.10) goto 1
6274 !
6275 !  Compute the axes of tghe local cartesian coordinates system; store in
6276 !   x_prime, y_prime and z_prime
6277 !
6278         do j=1,3
6279           x_prime(j) = 0.00
6280           y_prime(j) = 0.00
6281           z_prime(j) = 0.00
6282         enddo
6283 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6284 !     &   dc_norm(3,i+nres)
6285         do j = 1,3
6286           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6287           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6288         enddo
6289         do j = 1,3
6290           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6291         enddo
6292 !       write (2,*) "i",i
6293 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6294 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6295 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6296 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6297 !      & " xy",scalar(x_prime(1),y_prime(1)),
6298 !      & " xz",scalar(x_prime(1),z_prime(1)),
6299 !      & " yy",scalar(y_prime(1),y_prime(1)),
6300 !      & " yz",scalar(y_prime(1),z_prime(1)),
6301 !      & " zz",scalar(z_prime(1),z_prime(1))
6302 !
6303 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6304 ! to local coordinate system. Store in xx, yy, zz.
6305 !
6306         xx=0.0d0
6307         yy=0.0d0
6308         zz=0.0d0
6309         do j = 1,3
6310           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6311           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6312           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6313         enddo
6314
6315         xxtab(i)=xx
6316         yytab(i)=yy
6317         zztab(i)=zz
6318 !
6319 ! Compute the energy of the ith side cbain
6320 !
6321 !        write (2,*) "xx",xx," yy",yy," zz",zz
6322         it=iabs(itype(i,1))
6323         do j = 1,65
6324           x(j) = sc_parmin(j,it)
6325         enddo
6326 #ifdef CHECK_COORD
6327 !c diagnostics - remove later
6328         xx1 = dcos(alph(2))
6329         yy1 = dsin(alph(2))*dcos(omeg(2))
6330         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6331         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6332           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6333           xx1,yy1,zz1
6334 !,"  --- ", xx_w,yy_w,zz_w
6335 ! end diagnostics
6336 #endif
6337         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6338          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6339          + x(10)*yy*zz
6340         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6341          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6342          + x(20)*yy*zz
6343         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6344          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6345          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6346          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6347          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6348          +x(40)*xx*yy*zz
6349         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6350          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6351          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6352          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6353          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6354          +x(60)*xx*yy*zz
6355         dsc_i   = 0.743d0+x(61)
6356         dp2_i   = 1.9d0+x(62)
6357         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6358                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6359         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6360                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6361         s1=(1+x(63))/(0.1d0 + dscp1)
6362         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6363         s2=(1+x(65))/(0.1d0 + dscp2)
6364         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6365         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6366       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6367 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6368 !     &   sumene4,
6369 !     &   dscp1,dscp2,sumene
6370 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6371         escloc = escloc + sumene
6372 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6373 !     & ,zz,xx,yy
6374 !#define DEBUG
6375 #ifdef DEBUG
6376 !
6377 ! This section to check the numerical derivatives of the energy of ith side
6378 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6379 ! #define DEBUG in the code to turn it on.
6380 !
6381         write (2,*) "sumene               =",sumene
6382         aincr=1.0d-7
6383         xxsave=xx
6384         xx=xx+aincr
6385         write (2,*) xx,yy,zz
6386         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6387         de_dxx_num=(sumenep-sumene)/aincr
6388         xx=xxsave
6389         write (2,*) "xx+ sumene from enesc=",sumenep
6390         yysave=yy
6391         yy=yy+aincr
6392         write (2,*) xx,yy,zz
6393         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6394         de_dyy_num=(sumenep-sumene)/aincr
6395         yy=yysave
6396         write (2,*) "yy+ sumene from enesc=",sumenep
6397         zzsave=zz
6398         zz=zz+aincr
6399         write (2,*) xx,yy,zz
6400         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6401         de_dzz_num=(sumenep-sumene)/aincr
6402         zz=zzsave
6403         write (2,*) "zz+ sumene from enesc=",sumenep
6404         costsave=cost2tab(i+1)
6405         sintsave=sint2tab(i+1)
6406         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6407         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6408         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6409         de_dt_num=(sumenep-sumene)/aincr
6410         write (2,*) " t+ sumene from enesc=",sumenep
6411         cost2tab(i+1)=costsave
6412         sint2tab(i+1)=sintsave
6413 ! End of diagnostics section.
6414 #endif
6415 !
6416 ! Compute the gradient of esc
6417 !
6418 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6419         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6420         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6421         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6422         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6423         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6424         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6425         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6426         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6427         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6428            *(pom_s1/dscp1+pom_s16*dscp1**4)
6429         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6430            *(pom_s2/dscp2+pom_s26*dscp2**4)
6431         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6432         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6433         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6434         +x(40)*yy*zz
6435         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6436         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6437         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6438         +x(60)*yy*zz
6439         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6440               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6441               +(pom1+pom2)*pom_dx
6442 #ifdef DEBUG
6443         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6444 #endif
6445 !
6446         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6447         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6448         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6449         +x(40)*xx*zz
6450         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6451         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6452         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6453         +x(59)*zz**2 +x(60)*xx*zz
6454         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6455               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6456               +(pom1-pom2)*pom_dy
6457 #ifdef DEBUG
6458         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6459 #endif
6460 !
6461         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6462         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6463         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6464         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6465         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6466         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6467         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6468         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6469 #ifdef DEBUG
6470         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6471 #endif
6472 !
6473         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6474         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6475         +pom1*pom_dt1+pom2*pom_dt2
6476 #ifdef DEBUG
6477         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6478 #endif
6479 !
6480 !
6481        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6482        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6483        cosfac2xx=cosfac2*xx
6484        sinfac2yy=sinfac2*yy
6485        do k = 1,3
6486          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6487             vbld_inv(i+1)
6488          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6489             vbld_inv(i)
6490          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6491          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6492 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6493 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6494 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6495 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6496          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6497          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6498          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6499          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6500          dZZ_Ci1(k)=0.0d0
6501          dZZ_Ci(k)=0.0d0
6502          do j=1,3
6503            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6504            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6505            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6506            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6507          enddo
6508
6509          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6510          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6511          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6512          (z_prime(k)-zz*dC_norm(k,i+nres))
6513 !
6514          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6515          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6516        enddo
6517
6518        do k=1,3
6519          dXX_Ctab(k,i)=dXX_Ci(k)
6520          dXX_C1tab(k,i)=dXX_Ci1(k)
6521          dYY_Ctab(k,i)=dYY_Ci(k)
6522          dYY_C1tab(k,i)=dYY_Ci1(k)
6523          dZZ_Ctab(k,i)=dZZ_Ci(k)
6524          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6525          dXX_XYZtab(k,i)=dXX_XYZ(k)
6526          dYY_XYZtab(k,i)=dYY_XYZ(k)
6527          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6528        enddo
6529
6530        do k = 1,3
6531 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6532 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6533 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6534 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6535 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6536 !     &    dt_dci(k)
6537 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6538 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6539          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6540           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6541          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6542           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6543          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6544           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6545        enddo
6546 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6547 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6548
6549 ! to check gradient call subroutine check_grad
6550
6551     1 continue
6552       enddo
6553       return
6554       end subroutine esc
6555 !-----------------------------------------------------------------------------
6556       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6557 !      implicit none
6558       real(kind=8),dimension(65) :: x
6559       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6560         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6561
6562       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6563         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6564         + x(10)*yy*zz
6565       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6566         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6567         + x(20)*yy*zz
6568       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6569         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6570         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6571         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6572         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6573         +x(40)*xx*yy*zz
6574       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6575         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6576         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6577         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6578         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6579         +x(60)*xx*yy*zz
6580       dsc_i   = 0.743d0+x(61)
6581       dp2_i   = 1.9d0+x(62)
6582       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6583                 *(xx*cost2+yy*sint2))
6584       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6585                 *(xx*cost2-yy*sint2))
6586       s1=(1+x(63))/(0.1d0 + dscp1)
6587       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6588       s2=(1+x(65))/(0.1d0 + dscp2)
6589       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6590       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6591        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6592       enesc=sumene
6593       return
6594       end function enesc
6595 #endif
6596 !-----------------------------------------------------------------------------
6597       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6598 !
6599 ! This procedure calculates two-body contact function g(rij) and its derivative:
6600 !
6601 !           eps0ij                                     !       x < -1
6602 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6603 !            0                                         !       x > 1
6604 !
6605 ! where x=(rij-r0ij)/delta
6606 !
6607 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6608 !
6609 !      implicit none
6610       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6611       real(kind=8) :: x,x2,x4,delta
6612 !     delta=0.02D0*r0ij
6613 !      delta=0.2D0*r0ij
6614       x=(rij-r0ij)/delta
6615       if (x.lt.-1.0D0) then
6616         fcont=eps0ij
6617         fprimcont=0.0D0
6618       else if (x.le.1.0D0) then
6619         x2=x*x
6620         x4=x2*x2
6621         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6622         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6623       else
6624         fcont=0.0D0
6625         fprimcont=0.0D0
6626       endif
6627       return
6628       end subroutine gcont
6629 !-----------------------------------------------------------------------------
6630       subroutine splinthet(theti,delta,ss,ssder)
6631 !      implicit real*8 (a-h,o-z)
6632 !      include 'DIMENSIONS'
6633 !      include 'COMMON.VAR'
6634 !      include 'COMMON.GEO'
6635       real(kind=8) :: theti,delta,ss,ssder
6636       real(kind=8) :: thetup,thetlow
6637       thetup=pi-delta
6638       thetlow=delta
6639       if (theti.gt.pipol) then
6640         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6641       else
6642         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6643         ssder=-ssder
6644       endif
6645       return
6646       end subroutine splinthet
6647 !-----------------------------------------------------------------------------
6648       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6649 !      implicit none
6650       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6651       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6652       a1=fprim0*delta/(f1-f0)
6653       a2=3.0d0-2.0d0*a1
6654       a3=a1-2.0d0
6655       ksi=(x-x0)/delta
6656       ksi2=ksi*ksi
6657       ksi3=ksi2*ksi
6658       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6659       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6660       return
6661       end subroutine spline1
6662 !-----------------------------------------------------------------------------
6663       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6664 !      implicit none
6665       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6666       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6667       ksi=(x-x0)/delta
6668       ksi2=ksi*ksi
6669       ksi3=ksi2*ksi
6670       a1=fprim0x*delta
6671       a2=3*(f1x-f0x)-2*fprim0x*delta
6672       a3=fprim0x*delta-2*(f1x-f0x)
6673       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6674       return
6675       end subroutine spline2
6676 !-----------------------------------------------------------------------------
6677 #ifdef CRYST_TOR
6678 !-----------------------------------------------------------------------------
6679       subroutine etor(etors,edihcnstr)
6680 !      implicit real*8 (a-h,o-z)
6681 !      include 'DIMENSIONS'
6682 !      include 'COMMON.VAR'
6683 !      include 'COMMON.GEO'
6684 !      include 'COMMON.LOCAL'
6685 !      include 'COMMON.TORSION'
6686 !      include 'COMMON.INTERACT'
6687 !      include 'COMMON.DERIV'
6688 !      include 'COMMON.CHAIN'
6689 !      include 'COMMON.NAMES'
6690 !      include 'COMMON.IOUNITS'
6691 !      include 'COMMON.FFIELD'
6692 !      include 'COMMON.TORCNSTR'
6693 !      include 'COMMON.CONTROL'
6694       real(kind=8) :: etors,edihcnstr
6695       logical :: lprn
6696 !el local variables
6697       integer :: i,j,
6698       real(kind=8) :: phii,fac,etors_ii
6699
6700 ! Set lprn=.true. for debugging
6701       lprn=.false.
6702 !      lprn=.true.
6703       etors=0.0D0
6704       do i=iphi_start,iphi_end
6705       etors_ii=0.0D0
6706         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6707             .or. itype(i,1).eq.ntyp1) cycle
6708         itori=itortyp(itype(i-2,1))
6709         itori1=itortyp(itype(i-1,1))
6710         phii=phi(i)
6711         gloci=0.0D0
6712 ! Proline-Proline pair is a special case...
6713         if (itori.eq.3 .and. itori1.eq.3) then
6714           if (phii.gt.-dwapi3) then
6715             cosphi=dcos(3*phii)
6716             fac=1.0D0/(1.0D0-cosphi)
6717             etorsi=v1(1,3,3)*fac
6718             etorsi=etorsi+etorsi
6719             etors=etors+etorsi-v1(1,3,3)
6720             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6721             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6722           endif
6723           do j=1,3
6724             v1ij=v1(j+1,itori,itori1)
6725             v2ij=v2(j+1,itori,itori1)
6726             cosphi=dcos(j*phii)
6727             sinphi=dsin(j*phii)
6728             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6729             if (energy_dec) etors_ii=etors_ii+ &
6730                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6731             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6732           enddo
6733         else
6734           do j=1,nterm_old
6735             v1ij=v1(j,itori,itori1)
6736             v2ij=v2(j,itori,itori1)
6737             cosphi=dcos(j*phii)
6738             sinphi=dsin(j*phii)
6739             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6740             if (energy_dec) etors_ii=etors_ii+ &
6741                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6742             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6743           enddo
6744         endif
6745         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6746              'etor',i,etors_ii
6747         if (lprn) &
6748         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6749         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6750         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6751         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6752 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6753       enddo
6754 ! 6/20/98 - dihedral angle constraints
6755       edihcnstr=0.0d0
6756       do i=1,ndih_constr
6757         itori=idih_constr(i)
6758         phii=phi(itori)
6759         difi=phii-phi0(i)
6760         if (difi.gt.drange(i)) then
6761           difi=difi-drange(i)
6762           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6763           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6764         else if (difi.lt.-drange(i)) then
6765           difi=difi+drange(i)
6766           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6767           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6768         endif
6769 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6770 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6771       enddo
6772 !      write (iout,*) 'edihcnstr',edihcnstr
6773       return
6774       end subroutine etor
6775 !-----------------------------------------------------------------------------
6776       subroutine etor_d(etors_d)
6777       real(kind=8) :: etors_d
6778       etors_d=0.0d0
6779       return
6780       end subroutine etor_d
6781 #else
6782 !-----------------------------------------------------------------------------
6783       subroutine etor(etors,edihcnstr)
6784 !      implicit real*8 (a-h,o-z)
6785 !      include 'DIMENSIONS'
6786 !      include 'COMMON.VAR'
6787 !      include 'COMMON.GEO'
6788 !      include 'COMMON.LOCAL'
6789 !      include 'COMMON.TORSION'
6790 !      include 'COMMON.INTERACT'
6791 !      include 'COMMON.DERIV'
6792 !      include 'COMMON.CHAIN'
6793 !      include 'COMMON.NAMES'
6794 !      include 'COMMON.IOUNITS'
6795 !      include 'COMMON.FFIELD'
6796 !      include 'COMMON.TORCNSTR'
6797 !      include 'COMMON.CONTROL'
6798       real(kind=8) :: etors,edihcnstr
6799       logical :: lprn
6800 !el local variables
6801       integer :: i,j,iblock,itori,itori1
6802       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6803                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6804 ! Set lprn=.true. for debugging
6805       lprn=.false.
6806 !     lprn=.true.
6807       etors=0.0D0
6808       do i=iphi_start,iphi_end
6809         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6810              .or. itype(i-3,1).eq.ntyp1 &
6811              .or. itype(i,1).eq.ntyp1) cycle
6812         etors_ii=0.0D0
6813          if (iabs(itype(i,1)).eq.20) then
6814          iblock=2
6815          else
6816          iblock=1
6817          endif
6818         itori=itortyp(itype(i-2,1))
6819         itori1=itortyp(itype(i-1,1))
6820         phii=phi(i)
6821         gloci=0.0D0
6822 ! Regular cosine and sine terms
6823         do j=1,nterm(itori,itori1,iblock)
6824           v1ij=v1(j,itori,itori1,iblock)
6825           v2ij=v2(j,itori,itori1,iblock)
6826           cosphi=dcos(j*phii)
6827           sinphi=dsin(j*phii)
6828           etors=etors+v1ij*cosphi+v2ij*sinphi
6829           if (energy_dec) etors_ii=etors_ii+ &
6830                      v1ij*cosphi+v2ij*sinphi
6831           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6832         enddo
6833 ! Lorentz terms
6834 !                         v1
6835 !  E = SUM ----------------------------------- - v1
6836 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6837 !
6838         cosphi=dcos(0.5d0*phii)
6839         sinphi=dsin(0.5d0*phii)
6840         do j=1,nlor(itori,itori1,iblock)
6841           vl1ij=vlor1(j,itori,itori1)
6842           vl2ij=vlor2(j,itori,itori1)
6843           vl3ij=vlor3(j,itori,itori1)
6844           pom=vl2ij*cosphi+vl3ij*sinphi
6845           pom1=1.0d0/(pom*pom+1.0d0)
6846           etors=etors+vl1ij*pom1
6847           if (energy_dec) etors_ii=etors_ii+ &
6848                      vl1ij*pom1
6849           pom=-pom*pom1*pom1
6850           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6851         enddo
6852 ! Subtract the constant term
6853         etors=etors-v0(itori,itori1,iblock)
6854           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6855                'etor',i,etors_ii-v0(itori,itori1,iblock)
6856         if (lprn) &
6857         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6858         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6859         (v1(j,itori,itori1,iblock),j=1,6),&
6860         (v2(j,itori,itori1,iblock),j=1,6)
6861         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6862 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6863       enddo
6864 ! 6/20/98 - dihedral angle constraints
6865       edihcnstr=0.0d0
6866 !      do i=1,ndih_constr
6867       do i=idihconstr_start,idihconstr_end
6868         itori=idih_constr(i)
6869         phii=phi(itori)
6870         difi=pinorm(phii-phi0(i))
6871         if (difi.gt.drange(i)) then
6872           difi=difi-drange(i)
6873           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6874           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6875         else if (difi.lt.-drange(i)) then
6876           difi=difi+drange(i)
6877           edihcnstr=edihcnstr+0.25d0*ftors*difi**4
6878           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors*difi**3
6879         else
6880           difi=0.0
6881         endif
6882 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6883 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6884 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6885       enddo
6886 !d       write (iout,*) 'edihcnstr',edihcnstr
6887       return
6888       end subroutine etor
6889 !-----------------------------------------------------------------------------
6890       subroutine etor_d(etors_d)
6891 ! 6/23/01 Compute double torsional energy
6892 !      implicit real*8 (a-h,o-z)
6893 !      include 'DIMENSIONS'
6894 !      include 'COMMON.VAR'
6895 !      include 'COMMON.GEO'
6896 !      include 'COMMON.LOCAL'
6897 !      include 'COMMON.TORSION'
6898 !      include 'COMMON.INTERACT'
6899 !      include 'COMMON.DERIV'
6900 !      include 'COMMON.CHAIN'
6901 !      include 'COMMON.NAMES'
6902 !      include 'COMMON.IOUNITS'
6903 !      include 'COMMON.FFIELD'
6904 !      include 'COMMON.TORCNSTR'
6905       real(kind=8) :: etors_d,etors_d_ii
6906       logical :: lprn
6907 !el local variables
6908       integer :: i,j,k,l,itori,itori1,itori2,iblock
6909       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6910                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6911                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6912                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6913 ! Set lprn=.true. for debugging
6914       lprn=.false.
6915 !     lprn=.true.
6916       etors_d=0.0D0
6917 !      write(iout,*) "a tu??"
6918       do i=iphid_start,iphid_end
6919         etors_d_ii=0.0D0
6920         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6921             .or. itype(i-3,1).eq.ntyp1 &
6922             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6923         itori=itortyp(itype(i-2,1))
6924         itori1=itortyp(itype(i-1,1))
6925         itori2=itortyp(itype(i,1))
6926         phii=phi(i)
6927         phii1=phi(i+1)
6928         gloci1=0.0D0
6929         gloci2=0.0D0
6930         iblock=1
6931         if (iabs(itype(i+1,1)).eq.20) iblock=2
6932
6933 ! Regular cosine and sine terms
6934         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6935           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6936           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6937           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6938           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6939           cosphi1=dcos(j*phii)
6940           sinphi1=dsin(j*phii)
6941           cosphi2=dcos(j*phii1)
6942           sinphi2=dsin(j*phii1)
6943           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
6944            v2cij*cosphi2+v2sij*sinphi2
6945           if (energy_dec) etors_d_ii=etors_d_ii+ &
6946            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
6947           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6948           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6949         enddo
6950         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6951           do l=1,k-1
6952             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6953             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6954             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6955             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6956             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6957             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6958             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6959             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6960             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6961               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6962             if (energy_dec) etors_d_ii=etors_d_ii+ &
6963               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
6964               v1sdij*sinphi1p2+v2sdij*sinphi1m2
6965             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
6966               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6967             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
6968               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6969           enddo
6970         enddo
6971         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6972                             'etor_d',i,etors_d_ii
6973         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
6974         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
6975       enddo
6976       return
6977       end subroutine etor_d
6978 #endif
6979 !-----------------------------------------------------------------------------
6980       subroutine eback_sc_corr(esccor)
6981 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
6982 !        conformational states; temporarily implemented as differences
6983 !        between UNRES torsional potentials (dependent on three types of
6984 !        residues) and the torsional potentials dependent on all 20 types
6985 !        of residues computed from AM1  energy surfaces of terminally-blocked
6986 !        amino-acid residues.
6987 !      implicit real*8 (a-h,o-z)
6988 !      include 'DIMENSIONS'
6989 !      include 'COMMON.VAR'
6990 !      include 'COMMON.GEO'
6991 !      include 'COMMON.LOCAL'
6992 !      include 'COMMON.TORSION'
6993 !      include 'COMMON.SCCOR'
6994 !      include 'COMMON.INTERACT'
6995 !      include 'COMMON.DERIV'
6996 !      include 'COMMON.CHAIN'
6997 !      include 'COMMON.NAMES'
6998 !      include 'COMMON.IOUNITS'
6999 !      include 'COMMON.FFIELD'
7000 !      include 'COMMON.CONTROL'
7001       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7002                    cosphi,sinphi
7003       logical :: lprn
7004       integer :: i,interty,j,isccori,isccori1,intertyp
7005 ! Set lprn=.true. for debugging
7006       lprn=.false.
7007 !      lprn=.true.
7008 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7009       esccor=0.0D0
7010       do i=itau_start,itau_end
7011         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7012         esccor_ii=0.0D0
7013         isccori=isccortyp(itype(i-2,1))
7014         isccori1=isccortyp(itype(i-1,1))
7015
7016 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7017         phii=phi(i)
7018         do intertyp=1,3 !intertyp
7019          esccor_ii=0.0D0
7020 !c Added 09 May 2012 (Adasko)
7021 !c  Intertyp means interaction type of backbone mainchain correlation:
7022 !   1 = SC...Ca...Ca...Ca
7023 !   2 = Ca...Ca...Ca...SC
7024 !   3 = SC...Ca...Ca...SCi
7025         gloci=0.0D0
7026         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7027             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7028             (itype(i-1,1).eq.ntyp1))) &
7029           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7030            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7031            .or.(itype(i,1).eq.ntyp1))) &
7032           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7033             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7034             (itype(i-3,1).eq.ntyp1)))) cycle
7035         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7036         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7037        cycle
7038        do j=1,nterm_sccor(isccori,isccori1)
7039           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7040           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7041           cosphi=dcos(j*tauangle(intertyp,i))
7042           sinphi=dsin(j*tauangle(intertyp,i))
7043           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7044           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7045           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7046         enddo
7047         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7048                                 'esccor',i,intertyp,esccor_ii
7049 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7050         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7051         if (lprn) &
7052         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7053         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7054         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7055         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7056         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7057        enddo !intertyp
7058       enddo
7059
7060       return
7061       end subroutine eback_sc_corr
7062 !-----------------------------------------------------------------------------
7063       subroutine multibody(ecorr)
7064 ! This subroutine calculates multi-body contributions to energy following
7065 ! the idea of Skolnick et al. If side chains I and J make a contact and
7066 ! at the same time side chains I+1 and J+1 make a contact, an extra
7067 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7068 !      implicit real*8 (a-h,o-z)
7069 !      include 'DIMENSIONS'
7070 !      include 'COMMON.IOUNITS'
7071 !      include 'COMMON.DERIV'
7072 !      include 'COMMON.INTERACT'
7073 !      include 'COMMON.CONTACTS'
7074       real(kind=8),dimension(3) :: gx,gx1
7075       logical :: lprn
7076       real(kind=8) :: ecorr
7077       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7078 ! Set lprn=.true. for debugging
7079       lprn=.false.
7080
7081       if (lprn) then
7082         write (iout,'(a)') 'Contact function values:'
7083         do i=nnt,nct-2
7084           write (iout,'(i2,20(1x,i2,f10.5))') &
7085               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7086         enddo
7087       endif
7088       ecorr=0.0D0
7089
7090 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7091 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7092       do i=nnt,nct
7093         do j=1,3
7094           gradcorr(j,i)=0.0D0
7095           gradxorr(j,i)=0.0D0
7096         enddo
7097       enddo
7098       do i=nnt,nct-2
7099
7100         DO ISHIFT = 3,4
7101
7102         i1=i+ishift
7103         num_conti=num_cont(i)
7104         num_conti1=num_cont(i1)
7105         do jj=1,num_conti
7106           j=jcont(jj,i)
7107           do kk=1,num_conti1
7108             j1=jcont(kk,i1)
7109             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7110 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7111 !d   &                   ' ishift=',ishift
7112 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7113 ! The system gains extra energy.
7114               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7115             endif   ! j1==j+-ishift
7116           enddo     ! kk
7117         enddo       ! jj
7118
7119         ENDDO ! ISHIFT
7120
7121       enddo         ! i
7122       return
7123       end subroutine multibody
7124 !-----------------------------------------------------------------------------
7125       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7126 !      implicit real*8 (a-h,o-z)
7127 !      include 'DIMENSIONS'
7128 !      include 'COMMON.IOUNITS'
7129 !      include 'COMMON.DERIV'
7130 !      include 'COMMON.INTERACT'
7131 !      include 'COMMON.CONTACTS'
7132       real(kind=8),dimension(3) :: gx,gx1
7133       logical :: lprn
7134       integer :: i,j,k,l,jj,kk,m,ll
7135       real(kind=8) :: eij,ekl
7136       lprn=.false.
7137       eij=facont(jj,i)
7138       ekl=facont(kk,k)
7139 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7140 ! Calculate the multi-body contribution to energy.
7141 ! Calculate multi-body contributions to the gradient.
7142 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7143 !d   & k,l,(gacont(m,kk,k),m=1,3)
7144       do m=1,3
7145         gx(m) =ekl*gacont(m,jj,i)
7146         gx1(m)=eij*gacont(m,kk,k)
7147         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7148         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7149         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7150         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7151       enddo
7152       do m=i,j-1
7153         do ll=1,3
7154           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7155         enddo
7156       enddo
7157       do m=k,l-1
7158         do ll=1,3
7159           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7160         enddo
7161       enddo
7162       esccorr=-eij*ekl
7163       return
7164       end function esccorr
7165 !-----------------------------------------------------------------------------
7166       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7167 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7168 !      implicit real*8 (a-h,o-z)
7169 !      include 'DIMENSIONS'
7170 !      include 'COMMON.IOUNITS'
7171 #ifdef MPI
7172       include "mpif.h"
7173 !      integer :: maxconts !max_cont=maxconts  =nres/4
7174       integer,parameter :: max_dim=26
7175       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7176       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7177 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7178 !el      common /przechowalnia/ zapas
7179       integer :: status(MPI_STATUS_SIZE)
7180       integer,dimension((nres/4)*2) :: req !maxconts*2
7181       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7182 #endif
7183 !      include 'COMMON.SETUP'
7184 !      include 'COMMON.FFIELD'
7185 !      include 'COMMON.DERIV'
7186 !      include 'COMMON.INTERACT'
7187 !      include 'COMMON.CONTACTS'
7188 !      include 'COMMON.CONTROL'
7189 !      include 'COMMON.LOCAL'
7190       real(kind=8),dimension(3) :: gx,gx1
7191       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7192       logical :: lprn,ldone
7193 !el local variables
7194       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7195               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7196
7197 ! Set lprn=.true. for debugging
7198       lprn=.false.
7199 #ifdef MPI
7200 !      maxconts=nres/4
7201       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7202       n_corr=0
7203       n_corr1=0
7204       if (nfgtasks.le.1) goto 30
7205       if (lprn) then
7206         write (iout,'(a)') 'Contact function values before RECEIVE:'
7207         do i=nnt,nct-2
7208           write (iout,'(2i3,50(1x,i2,f5.2))') &
7209           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7210           j=1,num_cont_hb(i))
7211         enddo
7212       endif
7213       call flush(iout)
7214       do i=1,ntask_cont_from
7215         ncont_recv(i)=0
7216       enddo
7217       do i=1,ntask_cont_to
7218         ncont_sent(i)=0
7219       enddo
7220 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7221 !     & ntask_cont_to
7222 ! Make the list of contacts to send to send to other procesors
7223 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7224 !      call flush(iout)
7225       do i=iturn3_start,iturn3_end
7226 !        write (iout,*) "make contact list turn3",i," num_cont",
7227 !     &    num_cont_hb(i)
7228         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7229       enddo
7230       do i=iturn4_start,iturn4_end
7231 !        write (iout,*) "make contact list turn4",i," num_cont",
7232 !     &   num_cont_hb(i)
7233         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7234       enddo
7235       do ii=1,nat_sent
7236         i=iat_sent(ii)
7237 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7238 !     &    num_cont_hb(i)
7239         do j=1,num_cont_hb(i)
7240         do k=1,4
7241           jjc=jcont_hb(j,i)
7242           iproc=iint_sent_local(k,jjc,ii)
7243 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7244           if (iproc.gt.0) then
7245             ncont_sent(iproc)=ncont_sent(iproc)+1
7246             nn=ncont_sent(iproc)
7247             zapas(1,nn,iproc)=i
7248             zapas(2,nn,iproc)=jjc
7249             zapas(3,nn,iproc)=facont_hb(j,i)
7250             zapas(4,nn,iproc)=ees0p(j,i)
7251             zapas(5,nn,iproc)=ees0m(j,i)
7252             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7253             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7254             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7255             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7256             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7257             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7258             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7259             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7260             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7261             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7262             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7263             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7264             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7265             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7266             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7267             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7268             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7269             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7270             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7271             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7272             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7273           endif
7274         enddo
7275         enddo
7276       enddo
7277       if (lprn) then
7278       write (iout,*) &
7279         "Numbers of contacts to be sent to other processors",&
7280         (ncont_sent(i),i=1,ntask_cont_to)
7281       write (iout,*) "Contacts sent"
7282       do ii=1,ntask_cont_to
7283         nn=ncont_sent(ii)
7284         iproc=itask_cont_to(ii)
7285         write (iout,*) nn," contacts to processor",iproc,&
7286          " of CONT_TO_COMM group"
7287         do i=1,nn
7288           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7289         enddo
7290       enddo
7291       call flush(iout)
7292       endif
7293       CorrelType=477
7294       CorrelID=fg_rank+1
7295       CorrelType1=478
7296       CorrelID1=nfgtasks+fg_rank+1
7297       ireq=0
7298 ! Receive the numbers of needed contacts from other processors
7299       do ii=1,ntask_cont_from
7300         iproc=itask_cont_from(ii)
7301         ireq=ireq+1
7302         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7303           FG_COMM,req(ireq),IERR)
7304       enddo
7305 !      write (iout,*) "IRECV ended"
7306 !      call flush(iout)
7307 ! Send the number of contacts needed by other processors
7308       do ii=1,ntask_cont_to
7309         iproc=itask_cont_to(ii)
7310         ireq=ireq+1
7311         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7312           FG_COMM,req(ireq),IERR)
7313       enddo
7314 !      write (iout,*) "ISEND ended"
7315 !      write (iout,*) "number of requests (nn)",ireq
7316       call flush(iout)
7317       if (ireq.gt.0) &
7318         call MPI_Waitall(ireq,req,status_array,ierr)
7319 !      write (iout,*)
7320 !     &  "Numbers of contacts to be received from other processors",
7321 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7322 !      call flush(iout)
7323 ! Receive contacts
7324       ireq=0
7325       do ii=1,ntask_cont_from
7326         iproc=itask_cont_from(ii)
7327         nn=ncont_recv(ii)
7328 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7329 !     &   " of CONT_TO_COMM group"
7330         call flush(iout)
7331         if (nn.gt.0) then
7332           ireq=ireq+1
7333           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7334           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7335 !          write (iout,*) "ireq,req",ireq,req(ireq)
7336         endif
7337       enddo
7338 ! Send the contacts to processors that need them
7339       do ii=1,ntask_cont_to
7340         iproc=itask_cont_to(ii)
7341         nn=ncont_sent(ii)
7342 !        write (iout,*) nn," contacts to processor",iproc,
7343 !     &   " of CONT_TO_COMM group"
7344         if (nn.gt.0) then
7345           ireq=ireq+1
7346           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7347             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7348 !          write (iout,*) "ireq,req",ireq,req(ireq)
7349 !          do i=1,nn
7350 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7351 !          enddo
7352         endif
7353       enddo
7354 !      write (iout,*) "number of requests (contacts)",ireq
7355 !      write (iout,*) "req",(req(i),i=1,4)
7356 !      call flush(iout)
7357       if (ireq.gt.0) &
7358        call MPI_Waitall(ireq,req,status_array,ierr)
7359       do iii=1,ntask_cont_from
7360         iproc=itask_cont_from(iii)
7361         nn=ncont_recv(iii)
7362         if (lprn) then
7363         write (iout,*) "Received",nn," contacts from processor",iproc,&
7364          " of CONT_FROM_COMM group"
7365         call flush(iout)
7366         do i=1,nn
7367           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7368         enddo
7369         call flush(iout)
7370         endif
7371         do i=1,nn
7372           ii=zapas_recv(1,i,iii)
7373 ! Flag the received contacts to prevent double-counting
7374           jj=-zapas_recv(2,i,iii)
7375 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7376 !          call flush(iout)
7377           nnn=num_cont_hb(ii)+1
7378           num_cont_hb(ii)=nnn
7379           jcont_hb(nnn,ii)=jj
7380           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7381           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7382           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7383           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7384           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7385           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7386           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7387           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7388           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7389           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7390           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7391           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7392           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7393           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7394           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7395           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7396           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7397           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7398           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7399           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7400           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7401           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7402           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7403           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7404         enddo
7405       enddo
7406       call flush(iout)
7407       if (lprn) then
7408         write (iout,'(a)') 'Contact function values after receive:'
7409         do i=nnt,nct-2
7410           write (iout,'(2i3,50(1x,i3,f5.2))') &
7411           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7412           j=1,num_cont_hb(i))
7413         enddo
7414         call flush(iout)
7415       endif
7416    30 continue
7417 #endif
7418       if (lprn) then
7419         write (iout,'(a)') 'Contact function values:'
7420         do i=nnt,nct-2
7421           write (iout,'(2i3,50(1x,i3,f5.2))') &
7422           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7423           j=1,num_cont_hb(i))
7424         enddo
7425       endif
7426       ecorr=0.0D0
7427
7428 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7429 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7430 ! Remove the loop below after debugging !!!
7431       do i=nnt,nct
7432         do j=1,3
7433           gradcorr(j,i)=0.0D0
7434           gradxorr(j,i)=0.0D0
7435         enddo
7436       enddo
7437 ! Calculate the local-electrostatic correlation terms
7438       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7439         i1=i+1
7440         num_conti=num_cont_hb(i)
7441         num_conti1=num_cont_hb(i+1)
7442         do jj=1,num_conti
7443           j=jcont_hb(jj,i)
7444           jp=iabs(j)
7445           do kk=1,num_conti1
7446             j1=jcont_hb(kk,i1)
7447             jp1=iabs(j1)
7448 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7449 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7450             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7451                 .or. j.lt.0 .and. j1.gt.0) .and. &
7452                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7453 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7454 ! The system gains extra energy.
7455               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7456               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7457                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7458               n_corr=n_corr+1
7459             else if (j1.eq.j) then
7460 ! Contacts I-J and I-(J+1) occur simultaneously.
7461 ! The system loses extra energy.
7462 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7463             endif
7464           enddo ! kk
7465           do kk=1,num_conti
7466             j1=jcont_hb(kk,i)
7467 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7468 !    &         ' jj=',jj,' kk=',kk
7469             if (j1.eq.j+1) then
7470 ! Contacts I-J and (I+1)-J occur simultaneously.
7471 ! The system loses extra energy.
7472 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7473             endif ! j1==j+1
7474           enddo ! kk
7475         enddo ! jj
7476       enddo ! i
7477       return
7478       end subroutine multibody_hb
7479 !-----------------------------------------------------------------------------
7480       subroutine add_hb_contact(ii,jj,itask)
7481 !      implicit real*8 (a-h,o-z)
7482 !      include "DIMENSIONS"
7483 !      include "COMMON.IOUNITS"
7484 !      include "COMMON.CONTACTS"
7485 !      integer,parameter :: maxconts=nres/4
7486       integer,parameter :: max_dim=26
7487       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7488 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7489 !      common /przechowalnia/ zapas
7490       integer :: i,j,ii,jj,iproc,nn,jjc
7491       integer,dimension(4) :: itask
7492 !      write (iout,*) "itask",itask
7493       do i=1,2
7494         iproc=itask(i)
7495         if (iproc.gt.0) then
7496           do j=1,num_cont_hb(ii)
7497             jjc=jcont_hb(j,ii)
7498 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7499             if (jjc.eq.jj) then
7500               ncont_sent(iproc)=ncont_sent(iproc)+1
7501               nn=ncont_sent(iproc)
7502               zapas(1,nn,iproc)=ii
7503               zapas(2,nn,iproc)=jjc
7504               zapas(3,nn,iproc)=facont_hb(j,ii)
7505               zapas(4,nn,iproc)=ees0p(j,ii)
7506               zapas(5,nn,iproc)=ees0m(j,ii)
7507               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7508               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7509               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7510               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7511               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7512               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7513               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7514               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7515               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7516               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7517               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7518               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7519               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7520               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7521               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7522               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7523               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7524               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7525               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7526               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7527               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7528               exit
7529             endif
7530           enddo
7531         endif
7532       enddo
7533       return
7534       end subroutine add_hb_contact
7535 !-----------------------------------------------------------------------------
7536       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7537 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7538 !      implicit real*8 (a-h,o-z)
7539 !      include 'DIMENSIONS'
7540 !      include 'COMMON.IOUNITS'
7541       integer,parameter :: max_dim=70
7542 #ifdef MPI
7543       include "mpif.h"
7544 !      integer :: maxconts !max_cont=maxconts=nres/4
7545       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7546       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7547 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7548 !      common /przechowalnia/ zapas
7549       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7550         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7551         ierr,iii,nnn
7552 #endif
7553 !      include 'COMMON.SETUP'
7554 !      include 'COMMON.FFIELD'
7555 !      include 'COMMON.DERIV'
7556 !      include 'COMMON.LOCAL'
7557 !      include 'COMMON.INTERACT'
7558 !      include 'COMMON.CONTACTS'
7559 !      include 'COMMON.CHAIN'
7560 !      include 'COMMON.CONTROL'
7561       real(kind=8),dimension(3) :: gx,gx1
7562       integer,dimension(nres) :: num_cont_hb_old
7563       logical :: lprn,ldone
7564 !EL      double precision eello4,eello5,eelo6,eello_turn6
7565 !EL      external eello4,eello5,eello6,eello_turn6
7566 !el local variables
7567       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7568               j1,jp1,i1,num_conti1
7569       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7570       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7571
7572 ! Set lprn=.true. for debugging
7573       lprn=.false.
7574       eturn6=0.0d0
7575 #ifdef MPI
7576 !      maxconts=nres/4
7577       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7578       do i=1,nres
7579         num_cont_hb_old(i)=num_cont_hb(i)
7580       enddo
7581       n_corr=0
7582       n_corr1=0
7583       if (nfgtasks.le.1) goto 30
7584       if (lprn) then
7585         write (iout,'(a)') 'Contact function values before RECEIVE:'
7586         do i=nnt,nct-2
7587           write (iout,'(2i3,50(1x,i2,f5.2))') &
7588           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7589           j=1,num_cont_hb(i))
7590         enddo
7591       endif
7592       call flush(iout)
7593       do i=1,ntask_cont_from
7594         ncont_recv(i)=0
7595       enddo
7596       do i=1,ntask_cont_to
7597         ncont_sent(i)=0
7598       enddo
7599 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7600 !     & ntask_cont_to
7601 ! Make the list of contacts to send to send to other procesors
7602       do i=iturn3_start,iturn3_end
7603 !        write (iout,*) "make contact list turn3",i," num_cont",
7604 !     &    num_cont_hb(i)
7605         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7606       enddo
7607       do i=iturn4_start,iturn4_end
7608 !        write (iout,*) "make contact list turn4",i," num_cont",
7609 !     &   num_cont_hb(i)
7610         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7611       enddo
7612       do ii=1,nat_sent
7613         i=iat_sent(ii)
7614 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7615 !     &    num_cont_hb(i)
7616         do j=1,num_cont_hb(i)
7617         do k=1,4
7618           jjc=jcont_hb(j,i)
7619           iproc=iint_sent_local(k,jjc,ii)
7620 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7621           if (iproc.ne.0) then
7622             ncont_sent(iproc)=ncont_sent(iproc)+1
7623             nn=ncont_sent(iproc)
7624             zapas(1,nn,iproc)=i
7625             zapas(2,nn,iproc)=jjc
7626             zapas(3,nn,iproc)=d_cont(j,i)
7627             ind=3
7628             do kk=1,3
7629               ind=ind+1
7630               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7631             enddo
7632             do kk=1,2
7633               do ll=1,2
7634                 ind=ind+1
7635                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7636               enddo
7637             enddo
7638             do jj=1,5
7639               do kk=1,3
7640                 do ll=1,2
7641                   do mm=1,2
7642                     ind=ind+1
7643                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7644                   enddo
7645                 enddo
7646               enddo
7647             enddo
7648           endif
7649         enddo
7650         enddo
7651       enddo
7652       if (lprn) then
7653       write (iout,*) &
7654         "Numbers of contacts to be sent to other processors",&
7655         (ncont_sent(i),i=1,ntask_cont_to)
7656       write (iout,*) "Contacts sent"
7657       do ii=1,ntask_cont_to
7658         nn=ncont_sent(ii)
7659         iproc=itask_cont_to(ii)
7660         write (iout,*) nn," contacts to processor",iproc,&
7661          " of CONT_TO_COMM group"
7662         do i=1,nn
7663           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7664         enddo
7665       enddo
7666       call flush(iout)
7667       endif
7668       CorrelType=477
7669       CorrelID=fg_rank+1
7670       CorrelType1=478
7671       CorrelID1=nfgtasks+fg_rank+1
7672       ireq=0
7673 ! Receive the numbers of needed contacts from other processors
7674       do ii=1,ntask_cont_from
7675         iproc=itask_cont_from(ii)
7676         ireq=ireq+1
7677         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7678           FG_COMM,req(ireq),IERR)
7679       enddo
7680 !      write (iout,*) "IRECV ended"
7681 !      call flush(iout)
7682 ! Send the number of contacts needed by other processors
7683       do ii=1,ntask_cont_to
7684         iproc=itask_cont_to(ii)
7685         ireq=ireq+1
7686         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7687           FG_COMM,req(ireq),IERR)
7688       enddo
7689 !      write (iout,*) "ISEND ended"
7690 !      write (iout,*) "number of requests (nn)",ireq
7691       call flush(iout)
7692       if (ireq.gt.0) &
7693         call MPI_Waitall(ireq,req,status_array,ierr)
7694 !      write (iout,*)
7695 !     &  "Numbers of contacts to be received from other processors",
7696 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7697 !      call flush(iout)
7698 ! Receive contacts
7699       ireq=0
7700       do ii=1,ntask_cont_from
7701         iproc=itask_cont_from(ii)
7702         nn=ncont_recv(ii)
7703 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7704 !     &   " of CONT_TO_COMM group"
7705         call flush(iout)
7706         if (nn.gt.0) then
7707           ireq=ireq+1
7708           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7709           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7710 !          write (iout,*) "ireq,req",ireq,req(ireq)
7711         endif
7712       enddo
7713 ! Send the contacts to processors that need them
7714       do ii=1,ntask_cont_to
7715         iproc=itask_cont_to(ii)
7716         nn=ncont_sent(ii)
7717 !        write (iout,*) nn," contacts to processor",iproc,
7718 !     &   " of CONT_TO_COMM group"
7719         if (nn.gt.0) then
7720           ireq=ireq+1
7721           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7722             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7723 !          write (iout,*) "ireq,req",ireq,req(ireq)
7724 !          do i=1,nn
7725 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7726 !          enddo
7727         endif
7728       enddo
7729 !      write (iout,*) "number of requests (contacts)",ireq
7730 !      write (iout,*) "req",(req(i),i=1,4)
7731 !      call flush(iout)
7732       if (ireq.gt.0) &
7733        call MPI_Waitall(ireq,req,status_array,ierr)
7734       do iii=1,ntask_cont_from
7735         iproc=itask_cont_from(iii)
7736         nn=ncont_recv(iii)
7737         if (lprn) then
7738         write (iout,*) "Received",nn," contacts from processor",iproc,&
7739          " of CONT_FROM_COMM group"
7740         call flush(iout)
7741         do i=1,nn
7742           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7743         enddo
7744         call flush(iout)
7745         endif
7746         do i=1,nn
7747           ii=zapas_recv(1,i,iii)
7748 ! Flag the received contacts to prevent double-counting
7749           jj=-zapas_recv(2,i,iii)
7750 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7751 !          call flush(iout)
7752           nnn=num_cont_hb(ii)+1
7753           num_cont_hb(ii)=nnn
7754           jcont_hb(nnn,ii)=jj
7755           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7756           ind=3
7757           do kk=1,3
7758             ind=ind+1
7759             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7760           enddo
7761           do kk=1,2
7762             do ll=1,2
7763               ind=ind+1
7764               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7765             enddo
7766           enddo
7767           do jj=1,5
7768             do kk=1,3
7769               do ll=1,2
7770                 do mm=1,2
7771                   ind=ind+1
7772                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7773                 enddo
7774               enddo
7775             enddo
7776           enddo
7777         enddo
7778       enddo
7779       call flush(iout)
7780       if (lprn) then
7781         write (iout,'(a)') 'Contact function values after receive:'
7782         do i=nnt,nct-2
7783           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7784           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7785           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7786         enddo
7787         call flush(iout)
7788       endif
7789    30 continue
7790 #endif
7791       if (lprn) then
7792         write (iout,'(a)') 'Contact function values:'
7793         do i=nnt,nct-2
7794           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7795           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7796           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7797         enddo
7798       endif
7799       ecorr=0.0D0
7800       ecorr5=0.0d0
7801       ecorr6=0.0d0
7802
7803 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7804 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7805 ! Remove the loop below after debugging !!!
7806       do i=nnt,nct
7807         do j=1,3
7808           gradcorr(j,i)=0.0D0
7809           gradxorr(j,i)=0.0D0
7810         enddo
7811       enddo
7812 ! Calculate the dipole-dipole interaction energies
7813       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7814       do i=iatel_s,iatel_e+1
7815         num_conti=num_cont_hb(i)
7816         do jj=1,num_conti
7817           j=jcont_hb(jj,i)
7818 #ifdef MOMENT
7819           call dipole(i,j,jj)
7820 #endif
7821         enddo
7822       enddo
7823       endif
7824 ! Calculate the local-electrostatic correlation terms
7825 !                write (iout,*) "gradcorr5 in eello5 before loop"
7826 !                do iii=1,nres
7827 !                  write (iout,'(i5,3f10.5)')
7828 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7829 !                enddo
7830       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7831 !        write (iout,*) "corr loop i",i
7832         i1=i+1
7833         num_conti=num_cont_hb(i)
7834         num_conti1=num_cont_hb(i+1)
7835         do jj=1,num_conti
7836           j=jcont_hb(jj,i)
7837           jp=iabs(j)
7838           do kk=1,num_conti1
7839             j1=jcont_hb(kk,i1)
7840             jp1=iabs(j1)
7841 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7842 !     &         ' jj=',jj,' kk=',kk
7843 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7844             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7845                 .or. j.lt.0 .and. j1.gt.0) .and. &
7846                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7847 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7848 ! The system gains extra energy.
7849               n_corr=n_corr+1
7850               sqd1=dsqrt(d_cont(jj,i))
7851               sqd2=dsqrt(d_cont(kk,i1))
7852               sred_geom = sqd1*sqd2
7853               IF (sred_geom.lt.cutoff_corr) THEN
7854                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7855                   ekont,fprimcont)
7856 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7857 !d     &         ' jj=',jj,' kk=',kk
7858                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7859                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7860                 do l=1,3
7861                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7862                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7863                 enddo
7864                 n_corr1=n_corr1+1
7865 !d               write (iout,*) 'sred_geom=',sred_geom,
7866 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7867 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7868 !d               write (iout,*) "g_contij",g_contij
7869 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7870 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7871                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7872                 if (wcorr4.gt.0.0d0) &
7873                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7874                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7875                        write (iout,'(a6,4i5,0pf7.3)') &
7876                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7877 !                write (iout,*) "gradcorr5 before eello5"
7878 !                do iii=1,nres
7879 !                  write (iout,'(i5,3f10.5)')
7880 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7881 !                enddo
7882                 if (wcorr5.gt.0.0d0) &
7883                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7884 !                write (iout,*) "gradcorr5 after eello5"
7885 !                do iii=1,nres
7886 !                  write (iout,'(i5,3f10.5)')
7887 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7888 !                enddo
7889                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7890                        write (iout,'(a6,4i5,0pf7.3)') &
7891                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7892 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7893 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7894                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7895                      .or. wturn6.eq.0.0d0))then
7896 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7897                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7898                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7899                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7900 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7901 !d     &            'ecorr6=',ecorr6
7902 !d                write (iout,'(4e15.5)') sred_geom,
7903 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7904 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7905 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7906                 else if (wturn6.gt.0.0d0 &
7907                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7908 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7909                   eturn6=eturn6+eello_turn6(i,jj,kk)
7910                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7911                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7912 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7913                 endif
7914               ENDIF
7915 1111          continue
7916             endif
7917           enddo ! kk
7918         enddo ! jj
7919       enddo ! i
7920       do i=1,nres
7921         num_cont_hb(i)=num_cont_hb_old(i)
7922       enddo
7923 !                write (iout,*) "gradcorr5 in eello5"
7924 !                do iii=1,nres
7925 !                  write (iout,'(i5,3f10.5)')
7926 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7927 !                enddo
7928       return
7929       end subroutine multibody_eello
7930 !-----------------------------------------------------------------------------
7931       subroutine add_hb_contact_eello(ii,jj,itask)
7932 !      implicit real*8 (a-h,o-z)
7933 !      include "DIMENSIONS"
7934 !      include "COMMON.IOUNITS"
7935 !      include "COMMON.CONTACTS"
7936 !      integer,parameter :: maxconts=nres/4
7937       integer,parameter :: max_dim=70
7938       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7939 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7940 !      common /przechowalnia/ zapas
7941
7942       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
7943       integer,dimension(4) ::itask
7944 !      write (iout,*) "itask",itask
7945       do i=1,2
7946         iproc=itask(i)
7947         if (iproc.gt.0) then
7948           do j=1,num_cont_hb(ii)
7949             jjc=jcont_hb(j,ii)
7950 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
7951             if (jjc.eq.jj) then
7952               ncont_sent(iproc)=ncont_sent(iproc)+1
7953               nn=ncont_sent(iproc)
7954               zapas(1,nn,iproc)=ii
7955               zapas(2,nn,iproc)=jjc
7956               zapas(3,nn,iproc)=d_cont(j,ii)
7957               ind=3
7958               do kk=1,3
7959                 ind=ind+1
7960                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
7961               enddo
7962               do kk=1,2
7963                 do ll=1,2
7964                   ind=ind+1
7965                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
7966                 enddo
7967               enddo
7968               do jj=1,5
7969                 do kk=1,3
7970                   do ll=1,2
7971                     do mm=1,2
7972                       ind=ind+1
7973                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
7974                     enddo
7975                   enddo
7976                 enddo
7977               enddo
7978               exit
7979             endif
7980           enddo
7981         endif
7982       enddo
7983       return
7984       end subroutine add_hb_contact_eello
7985 !-----------------------------------------------------------------------------
7986       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
7987 !      implicit real*8 (a-h,o-z)
7988 !      include 'DIMENSIONS'
7989 !      include 'COMMON.IOUNITS'
7990 !      include 'COMMON.DERIV'
7991 !      include 'COMMON.INTERACT'
7992 !      include 'COMMON.CONTACTS'
7993       real(kind=8),dimension(3) :: gx,gx1
7994       logical :: lprn
7995 !el local variables
7996       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
7997       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
7998                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
7999                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8000                    rlocshield
8001
8002       lprn=.false.
8003       eij=facont_hb(jj,i)
8004       ekl=facont_hb(kk,k)
8005       ees0pij=ees0p(jj,i)
8006       ees0pkl=ees0p(kk,k)
8007       ees0mij=ees0m(jj,i)
8008       ees0mkl=ees0m(kk,k)
8009       ekont=eij*ekl
8010       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8011 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8012 ! Following 4 lines for diagnostics.
8013 !d    ees0pkl=0.0D0
8014 !d    ees0pij=1.0D0
8015 !d    ees0mkl=0.0D0
8016 !d    ees0mij=1.0D0
8017 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8018 !     & 'Contacts ',i,j,
8019 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8020 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8021 !     & 'gradcorr_long'
8022 ! Calculate the multi-body contribution to energy.
8023 !      ecorr=ecorr+ekont*ees
8024 ! Calculate multi-body contributions to the gradient.
8025       coeffpees0pij=coeffp*ees0pij
8026       coeffmees0mij=coeffm*ees0mij
8027       coeffpees0pkl=coeffp*ees0pkl
8028       coeffmees0mkl=coeffm*ees0mkl
8029       do ll=1,3
8030 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8031         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8032         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8033         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8034         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8035         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8036         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8037 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8038         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8039         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8040         coeffmees0mij*gacontm_hb1(ll,kk,k))
8041         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8042         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8043         coeffmees0mij*gacontm_hb2(ll,kk,k))
8044         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8045            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8046            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8047         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8048         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8049         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8050            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8051            coeffmees0mij*gacontm_hb3(ll,kk,k))
8052         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8053         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8054 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8055       enddo
8056 !      write (iout,*)
8057 !grad      do m=i+1,j-1
8058 !grad        do ll=1,3
8059 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8060 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8061 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8062 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8063 !grad        enddo
8064 !grad      enddo
8065 !grad      do m=k+1,l-1
8066 !grad        do ll=1,3
8067 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8068 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8069 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8070 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8071 !grad        enddo
8072 !grad      enddo
8073 !      write (iout,*) "ehbcorr",ekont*ees
8074       ehbcorr=ekont*ees
8075       if (shield_mode.gt.0) then
8076        j=ees0plist(jj,i)
8077        l=ees0plist(kk,k)
8078 !C        print *,i,j,fac_shield(i),fac_shield(j),
8079 !C     &fac_shield(k),fac_shield(l)
8080         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8081            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8082           do ilist=1,ishield_list(i)
8083            iresshield=shield_list(ilist,i)
8084            do m=1,3
8085            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8086            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8087                    rlocshield  &
8088             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8089             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8090             +rlocshield
8091            enddo
8092           enddo
8093           do ilist=1,ishield_list(j)
8094            iresshield=shield_list(ilist,j)
8095            do m=1,3
8096            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8097            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8098                    rlocshield &
8099             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8100            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8101             +rlocshield
8102            enddo
8103           enddo
8104
8105           do ilist=1,ishield_list(k)
8106            iresshield=shield_list(ilist,k)
8107            do m=1,3
8108            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8109            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8110                    rlocshield &
8111             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8112            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8113             +rlocshield
8114            enddo
8115           enddo
8116           do ilist=1,ishield_list(l)
8117            iresshield=shield_list(ilist,l)
8118            do m=1,3
8119            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8120            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8121                    rlocshield &
8122             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8123            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8124             +rlocshield
8125            enddo
8126           enddo
8127           do m=1,3
8128             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8129                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8130             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8131                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8132             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8133                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8134             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8135                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8136
8137             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8138                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8139             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8140                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8141             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8142                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8143             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8144                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8145
8146            enddo
8147       endif
8148       endif
8149       return
8150       end function ehbcorr
8151 #ifdef MOMENT
8152 !-----------------------------------------------------------------------------
8153       subroutine dipole(i,j,jj)
8154 !      implicit real*8 (a-h,o-z)
8155 !      include 'DIMENSIONS'
8156 !      include 'COMMON.IOUNITS'
8157 !      include 'COMMON.CHAIN'
8158 !      include 'COMMON.FFIELD'
8159 !      include 'COMMON.DERIV'
8160 !      include 'COMMON.INTERACT'
8161 !      include 'COMMON.CONTACTS'
8162 !      include 'COMMON.TORSION'
8163 !      include 'COMMON.VAR'
8164 !      include 'COMMON.GEO'
8165       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8166       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8167       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8168
8169       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8170       allocate(dipderx(3,5,4,maxconts,nres))
8171 !
8172
8173       iti1 = itortyp(itype(i+1,1))
8174       if (j.lt.nres-1) then
8175         itj1 = itortyp(itype(j+1,1))
8176       else
8177         itj1=ntortyp+1
8178       endif
8179       do iii=1,2
8180         dipi(iii,1)=Ub2(iii,i)
8181         dipderi(iii)=Ub2der(iii,i)
8182         dipi(iii,2)=b1(iii,iti1)
8183         dipj(iii,1)=Ub2(iii,j)
8184         dipderj(iii)=Ub2der(iii,j)
8185         dipj(iii,2)=b1(iii,itj1)
8186       enddo
8187       kkk=0
8188       do iii=1,2
8189         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8190         do jjj=1,2
8191           kkk=kkk+1
8192           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8193         enddo
8194       enddo
8195       do kkk=1,5
8196         do lll=1,3
8197           mmm=0
8198           do iii=1,2
8199             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8200               auxvec(1))
8201             do jjj=1,2
8202               mmm=mmm+1
8203               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8204             enddo
8205           enddo
8206         enddo
8207       enddo
8208       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8209       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8210       do iii=1,2
8211         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8212       enddo
8213       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8214       do iii=1,2
8215         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8216       enddo
8217       return
8218       end subroutine dipole
8219 #endif
8220 !-----------------------------------------------------------------------------
8221       subroutine calc_eello(i,j,k,l,jj,kk)
8222 !
8223 ! This subroutine computes matrices and vectors needed to calculate
8224 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8225 !
8226       use comm_kut
8227 !      implicit real*8 (a-h,o-z)
8228 !      include 'DIMENSIONS'
8229 !      include 'COMMON.IOUNITS'
8230 !      include 'COMMON.CHAIN'
8231 !      include 'COMMON.DERIV'
8232 !      include 'COMMON.INTERACT'
8233 !      include 'COMMON.CONTACTS'
8234 !      include 'COMMON.TORSION'
8235 !      include 'COMMON.VAR'
8236 !      include 'COMMON.GEO'
8237 !      include 'COMMON.FFIELD'
8238       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8239       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8240       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8241               itj1
8242 !el      logical :: lprn
8243 !el      common /kutas/ lprn
8244 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8245 !d     & ' jj=',jj,' kk=',kk
8246 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8247 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8248 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8249       do iii=1,2
8250         do jjj=1,2
8251           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8252           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8253         enddo
8254       enddo
8255       call transpose2(aa1(1,1),aa1t(1,1))
8256       call transpose2(aa2(1,1),aa2t(1,1))
8257       do kkk=1,5
8258         do lll=1,3
8259           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8260             aa1tder(1,1,lll,kkk))
8261           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8262             aa2tder(1,1,lll,kkk))
8263         enddo
8264       enddo
8265       if (l.eq.j+1) then
8266 ! parallel orientation of the two CA-CA-CA frames.
8267         if (i.gt.1) then
8268           iti=itortyp(itype(i,1))
8269         else
8270           iti=ntortyp+1
8271         endif
8272         itk1=itortyp(itype(k+1,1))
8273         itj=itortyp(itype(j,1))
8274         if (l.lt.nres-1) then
8275           itl1=itortyp(itype(l+1,1))
8276         else
8277           itl1=ntortyp+1
8278         endif
8279 ! A1 kernel(j+1) A2T
8280 !d        do iii=1,2
8281 !d          write (iout,'(3f10.5,5x,3f10.5)')
8282 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8283 !d        enddo
8284         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8285          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8286          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8287 ! Following matrices are needed only for 6-th order cumulants
8288         IF (wcorr6.gt.0.0d0) THEN
8289         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8290          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8291          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8292         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8293          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8294          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8295          ADtEAderx(1,1,1,1,1,1))
8296         lprn=.false.
8297         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8298          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8299          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8300          ADtEA1derx(1,1,1,1,1,1))
8301         ENDIF
8302 ! End 6-th order cumulants
8303 !d        lprn=.false.
8304 !d        if (lprn) then
8305 !d        write (2,*) 'In calc_eello6'
8306 !d        do iii=1,2
8307 !d          write (2,*) 'iii=',iii
8308 !d          do kkk=1,5
8309 !d            write (2,*) 'kkk=',kkk
8310 !d            do jjj=1,2
8311 !d              write (2,'(3(2f10.5),5x)')
8312 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8313 !d            enddo
8314 !d          enddo
8315 !d        enddo
8316 !d        endif
8317         call transpose2(EUgder(1,1,k),auxmat(1,1))
8318         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8319         call transpose2(EUg(1,1,k),auxmat(1,1))
8320         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8321         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8322         do iii=1,2
8323           do kkk=1,5
8324             do lll=1,3
8325               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8326                 EAEAderx(1,1,lll,kkk,iii,1))
8327             enddo
8328           enddo
8329         enddo
8330 ! A1T kernel(i+1) A2
8331         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8332          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8333          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8334 ! Following matrices are needed only for 6-th order cumulants
8335         IF (wcorr6.gt.0.0d0) THEN
8336         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8337          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8338          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8339         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8340          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8341          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8342          ADtEAderx(1,1,1,1,1,2))
8343         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8344          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8345          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8346          ADtEA1derx(1,1,1,1,1,2))
8347         ENDIF
8348 ! End 6-th order cumulants
8349         call transpose2(EUgder(1,1,l),auxmat(1,1))
8350         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8351         call transpose2(EUg(1,1,l),auxmat(1,1))
8352         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8353         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8354         do iii=1,2
8355           do kkk=1,5
8356             do lll=1,3
8357               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8358                 EAEAderx(1,1,lll,kkk,iii,2))
8359             enddo
8360           enddo
8361         enddo
8362 ! AEAb1 and AEAb2
8363 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8364 ! They are needed only when the fifth- or the sixth-order cumulants are
8365 ! indluded.
8366         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8367         call transpose2(AEA(1,1,1),auxmat(1,1))
8368         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8369         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8370         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8371         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8372         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8373         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8374         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8375         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8376         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8377         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8378         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8379         call transpose2(AEA(1,1,2),auxmat(1,1))
8380         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8381         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8382         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8383         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8384         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8385         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8386         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8387         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8388         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8389         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8390         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8391 ! Calculate the Cartesian derivatives of the vectors.
8392         do iii=1,2
8393           do kkk=1,5
8394             do lll=1,3
8395               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8396               call matvec2(auxmat(1,1),b1(1,iti),&
8397                 AEAb1derx(1,lll,kkk,iii,1,1))
8398               call matvec2(auxmat(1,1),Ub2(1,i),&
8399                 AEAb2derx(1,lll,kkk,iii,1,1))
8400               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8401                 AEAb1derx(1,lll,kkk,iii,2,1))
8402               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8403                 AEAb2derx(1,lll,kkk,iii,2,1))
8404               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8405               call matvec2(auxmat(1,1),b1(1,itj),&
8406                 AEAb1derx(1,lll,kkk,iii,1,2))
8407               call matvec2(auxmat(1,1),Ub2(1,j),&
8408                 AEAb2derx(1,lll,kkk,iii,1,2))
8409               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8410                 AEAb1derx(1,lll,kkk,iii,2,2))
8411               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8412                 AEAb2derx(1,lll,kkk,iii,2,2))
8413             enddo
8414           enddo
8415         enddo
8416         ENDIF
8417 ! End vectors
8418       else
8419 ! Antiparallel orientation of the two CA-CA-CA frames.
8420         if (i.gt.1) then
8421           iti=itortyp(itype(i,1))
8422         else
8423           iti=ntortyp+1
8424         endif
8425         itk1=itortyp(itype(k+1,1))
8426         itl=itortyp(itype(l,1))
8427         itj=itortyp(itype(j,1))
8428         if (j.lt.nres-1) then
8429           itj1=itortyp(itype(j+1,1))
8430         else
8431           itj1=ntortyp+1
8432         endif
8433 ! A2 kernel(j-1)T A1T
8434         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8435          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8436          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8437 ! Following matrices are needed only for 6-th order cumulants
8438         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8439            j.eq.i+4 .and. l.eq.i+3)) THEN
8440         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8441          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8442          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8443         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8444          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8445          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8446          ADtEAderx(1,1,1,1,1,1))
8447         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8448          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8449          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8450          ADtEA1derx(1,1,1,1,1,1))
8451         ENDIF
8452 ! End 6-th order cumulants
8453         call transpose2(EUgder(1,1,k),auxmat(1,1))
8454         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8455         call transpose2(EUg(1,1,k),auxmat(1,1))
8456         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8457         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8458         do iii=1,2
8459           do kkk=1,5
8460             do lll=1,3
8461               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8462                 EAEAderx(1,1,lll,kkk,iii,1))
8463             enddo
8464           enddo
8465         enddo
8466 ! A2T kernel(i+1)T A1
8467         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8468          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8469          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8470 ! Following matrices are needed only for 6-th order cumulants
8471         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8472            j.eq.i+4 .and. l.eq.i+3)) THEN
8473         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8474          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8475          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8476         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8477          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8478          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8479          ADtEAderx(1,1,1,1,1,2))
8480         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8481          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8482          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8483          ADtEA1derx(1,1,1,1,1,2))
8484         ENDIF
8485 ! End 6-th order cumulants
8486         call transpose2(EUgder(1,1,j),auxmat(1,1))
8487         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8488         call transpose2(EUg(1,1,j),auxmat(1,1))
8489         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8490         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8491         do iii=1,2
8492           do kkk=1,5
8493             do lll=1,3
8494               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8495                 EAEAderx(1,1,lll,kkk,iii,2))
8496             enddo
8497           enddo
8498         enddo
8499 ! AEAb1 and AEAb2
8500 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8501 ! They are needed only when the fifth- or the sixth-order cumulants are
8502 ! indluded.
8503         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8504           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8505         call transpose2(AEA(1,1,1),auxmat(1,1))
8506         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8507         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8508         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8509         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8510         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8511         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8512         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8513         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8514         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8515         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8516         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8517         call transpose2(AEA(1,1,2),auxmat(1,1))
8518         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8519         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8520         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8521         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8522         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8523         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8524         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8525         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8526         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8527         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8528         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8529 ! Calculate the Cartesian derivatives of the vectors.
8530         do iii=1,2
8531           do kkk=1,5
8532             do lll=1,3
8533               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8534               call matvec2(auxmat(1,1),b1(1,iti),&
8535                 AEAb1derx(1,lll,kkk,iii,1,1))
8536               call matvec2(auxmat(1,1),Ub2(1,i),&
8537                 AEAb2derx(1,lll,kkk,iii,1,1))
8538               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8539                 AEAb1derx(1,lll,kkk,iii,2,1))
8540               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8541                 AEAb2derx(1,lll,kkk,iii,2,1))
8542               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8543               call matvec2(auxmat(1,1),b1(1,itl),&
8544                 AEAb1derx(1,lll,kkk,iii,1,2))
8545               call matvec2(auxmat(1,1),Ub2(1,l),&
8546                 AEAb2derx(1,lll,kkk,iii,1,2))
8547               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8548                 AEAb1derx(1,lll,kkk,iii,2,2))
8549               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8550                 AEAb2derx(1,lll,kkk,iii,2,2))
8551             enddo
8552           enddo
8553         enddo
8554         ENDIF
8555 ! End vectors
8556       endif
8557       return
8558       end subroutine calc_eello
8559 !-----------------------------------------------------------------------------
8560       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8561       use comm_kut
8562       implicit none
8563       integer :: nderg
8564       logical :: transp
8565       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8566       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8567       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8568       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8569       integer :: iii,kkk,lll
8570       integer :: jjj,mmm
8571 !el      logical :: lprn
8572 !el      common /kutas/ lprn
8573       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8574       do iii=1,nderg
8575         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8576           AKAderg(1,1,iii))
8577       enddo
8578 !d      if (lprn) write (2,*) 'In kernel'
8579       do kkk=1,5
8580 !d        if (lprn) write (2,*) 'kkk=',kkk
8581         do lll=1,3
8582           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8583             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8584 !d          if (lprn) then
8585 !d            write (2,*) 'lll=',lll
8586 !d            write (2,*) 'iii=1'
8587 !d            do jjj=1,2
8588 !d              write (2,'(3(2f10.5),5x)')
8589 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8590 !d            enddo
8591 !d          endif
8592           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8593             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8594 !d          if (lprn) then
8595 !d            write (2,*) 'lll=',lll
8596 !d            write (2,*) 'iii=2'
8597 !d            do jjj=1,2
8598 !d              write (2,'(3(2f10.5),5x)')
8599 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8600 !d            enddo
8601 !d          endif
8602         enddo
8603       enddo
8604       return
8605       end subroutine kernel
8606 !-----------------------------------------------------------------------------
8607       real(kind=8) function eello4(i,j,k,l,jj,kk)
8608 !      implicit real*8 (a-h,o-z)
8609 !      include 'DIMENSIONS'
8610 !      include 'COMMON.IOUNITS'
8611 !      include 'COMMON.CHAIN'
8612 !      include 'COMMON.DERIV'
8613 !      include 'COMMON.INTERACT'
8614 !      include 'COMMON.CONTACTS'
8615 !      include 'COMMON.TORSION'
8616 !      include 'COMMON.VAR'
8617 !      include 'COMMON.GEO'
8618       real(kind=8),dimension(2,2) :: pizda
8619       real(kind=8),dimension(3) :: ggg1,ggg2
8620       real(kind=8) ::  eel4,glongij,glongkl
8621       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8622 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8623 !d        eello4=0.0d0
8624 !d        return
8625 !d      endif
8626 !d      print *,'eello4:',i,j,k,l,jj,kk
8627 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8628 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8629 !old      eij=facont_hb(jj,i)
8630 !old      ekl=facont_hb(kk,k)
8631 !old      ekont=eij*ekl
8632       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8633 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8634       gcorr_loc(k-1)=gcorr_loc(k-1) &
8635          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8636       if (l.eq.j+1) then
8637         gcorr_loc(l-1)=gcorr_loc(l-1) &
8638            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8639       else
8640         gcorr_loc(j-1)=gcorr_loc(j-1) &
8641            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8642       endif
8643       do iii=1,2
8644         do kkk=1,5
8645           do lll=1,3
8646             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8647                               -EAEAderx(2,2,lll,kkk,iii,1)
8648 !d            derx(lll,kkk,iii)=0.0d0
8649           enddo
8650         enddo
8651       enddo
8652 !d      gcorr_loc(l-1)=0.0d0
8653 !d      gcorr_loc(j-1)=0.0d0
8654 !d      gcorr_loc(k-1)=0.0d0
8655 !d      eel4=1.0d0
8656 !d      write (iout,*)'Contacts have occurred for peptide groups',
8657 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8658 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8659       if (j.lt.nres-1) then
8660         j1=j+1
8661         j2=j-1
8662       else
8663         j1=j-1
8664         j2=j-2
8665       endif
8666       if (l.lt.nres-1) then
8667         l1=l+1
8668         l2=l-1
8669       else
8670         l1=l-1
8671         l2=l-2
8672       endif
8673       do ll=1,3
8674 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8675 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8676         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8677         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8678 !grad        ghalf=0.5d0*ggg1(ll)
8679         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8680         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8681         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8682         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8683         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8684         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8685 !grad        ghalf=0.5d0*ggg2(ll)
8686         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8687         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8688         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8689         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8690         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8691         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8692       enddo
8693 !grad      do m=i+1,j-1
8694 !grad        do ll=1,3
8695 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8696 !grad        enddo
8697 !grad      enddo
8698 !grad      do m=k+1,l-1
8699 !grad        do ll=1,3
8700 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8701 !grad        enddo
8702 !grad      enddo
8703 !grad      do m=i+2,j2
8704 !grad        do ll=1,3
8705 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8706 !grad        enddo
8707 !grad      enddo
8708 !grad      do m=k+2,l2
8709 !grad        do ll=1,3
8710 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8711 !grad        enddo
8712 !grad      enddo
8713 !d      do iii=1,nres-3
8714 !d        write (2,*) iii,gcorr_loc(iii)
8715 !d      enddo
8716       eello4=ekont*eel4
8717 !d      write (2,*) 'ekont',ekont
8718 !d      write (iout,*) 'eello4',ekont*eel4
8719       return
8720       end function eello4
8721 !-----------------------------------------------------------------------------
8722       real(kind=8) function eello5(i,j,k,l,jj,kk)
8723 !      implicit real*8 (a-h,o-z)
8724 !      include 'DIMENSIONS'
8725 !      include 'COMMON.IOUNITS'
8726 !      include 'COMMON.CHAIN'
8727 !      include 'COMMON.DERIV'
8728 !      include 'COMMON.INTERACT'
8729 !      include 'COMMON.CONTACTS'
8730 !      include 'COMMON.TORSION'
8731 !      include 'COMMON.VAR'
8732 !      include 'COMMON.GEO'
8733       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8734       real(kind=8),dimension(2) :: vv
8735       real(kind=8),dimension(3) :: ggg1,ggg2
8736       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8737       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8738       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8739 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8740 !                                                                              C
8741 !                            Parallel chains                                   C
8742 !                                                                              C
8743 !          o             o                   o             o                   C
8744 !         /l\           / \             \   / \           / \   /              C
8745 !        /   \         /   \             \ /   \         /   \ /               C
8746 !       j| o |l1       | o |                o| o |         | o |o                C
8747 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8748 !      \i/   \         /   \ /             /   \         /   \                 C
8749 !       o    k1             o                                                  C
8750 !         (I)          (II)                (III)          (IV)                 C
8751 !                                                                              C
8752 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8753 !                                                                              C
8754 !                            Antiparallel chains                               C
8755 !                                                                              C
8756 !          o             o                   o             o                   C
8757 !         /j\           / \             \   / \           / \   /              C
8758 !        /   \         /   \             \ /   \         /   \ /               C
8759 !      j1| o |l        | o |                o| o |         | o |o                C
8760 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8761 !      \i/   \         /   \ /             /   \         /   \                 C
8762 !       o     k1            o                                                  C
8763 !         (I)          (II)                (III)          (IV)                 C
8764 !                                                                              C
8765 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8766 !                                                                              C
8767 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8768 !                                                                              C
8769 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8770 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8771 !d        eello5=0.0d0
8772 !d        return
8773 !d      endif
8774 !d      write (iout,*)
8775 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8776 !d     &   ' and',k,l
8777       itk=itortyp(itype(k,1))
8778       itl=itortyp(itype(l,1))
8779       itj=itortyp(itype(j,1))
8780       eello5_1=0.0d0
8781       eello5_2=0.0d0
8782       eello5_3=0.0d0
8783       eello5_4=0.0d0
8784 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8785 !d     &   eel5_3_num,eel5_4_num)
8786       do iii=1,2
8787         do kkk=1,5
8788           do lll=1,3
8789             derx(lll,kkk,iii)=0.0d0
8790           enddo
8791         enddo
8792       enddo
8793 !d      eij=facont_hb(jj,i)
8794 !d      ekl=facont_hb(kk,k)
8795 !d      ekont=eij*ekl
8796 !d      write (iout,*)'Contacts have occurred for peptide groups',
8797 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8798 !d      goto 1111
8799 ! Contribution from the graph I.
8800 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8801 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8802       call transpose2(EUg(1,1,k),auxmat(1,1))
8803       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8804       vv(1)=pizda(1,1)-pizda(2,2)
8805       vv(2)=pizda(1,2)+pizda(2,1)
8806       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8807        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8808 ! Explicit gradient in virtual-dihedral angles.
8809       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8810        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8811        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8812       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8813       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8814       vv(1)=pizda(1,1)-pizda(2,2)
8815       vv(2)=pizda(1,2)+pizda(2,1)
8816       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8817        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8818        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8819       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8820       vv(1)=pizda(1,1)-pizda(2,2)
8821       vv(2)=pizda(1,2)+pizda(2,1)
8822       if (l.eq.j+1) then
8823         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8824          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8825          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8826       else
8827         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8828          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8829          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8830       endif
8831 ! Cartesian gradient
8832       do iii=1,2
8833         do kkk=1,5
8834           do lll=1,3
8835             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8836               pizda(1,1))
8837             vv(1)=pizda(1,1)-pizda(2,2)
8838             vv(2)=pizda(1,2)+pizda(2,1)
8839             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8840              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8841              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8842           enddo
8843         enddo
8844       enddo
8845 !      goto 1112
8846 !1111  continue
8847 ! Contribution from graph II
8848       call transpose2(EE(1,1,itk),auxmat(1,1))
8849       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8850       vv(1)=pizda(1,1)+pizda(2,2)
8851       vv(2)=pizda(2,1)-pizda(1,2)
8852       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8853        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8854 ! Explicit gradient in virtual-dihedral angles.
8855       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8856        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8857       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8858       vv(1)=pizda(1,1)+pizda(2,2)
8859       vv(2)=pizda(2,1)-pizda(1,2)
8860       if (l.eq.j+1) then
8861         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8862          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8863          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8864       else
8865         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8866          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8867          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8868       endif
8869 ! Cartesian gradient
8870       do iii=1,2
8871         do kkk=1,5
8872           do lll=1,3
8873             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8874               pizda(1,1))
8875             vv(1)=pizda(1,1)+pizda(2,2)
8876             vv(2)=pizda(2,1)-pizda(1,2)
8877             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8878              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8879              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8880           enddo
8881         enddo
8882       enddo
8883 !d      goto 1112
8884 !d1111  continue
8885       if (l.eq.j+1) then
8886 !d        goto 1110
8887 ! Parallel orientation
8888 ! Contribution from graph III
8889         call transpose2(EUg(1,1,l),auxmat(1,1))
8890         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8891         vv(1)=pizda(1,1)-pizda(2,2)
8892         vv(2)=pizda(1,2)+pizda(2,1)
8893         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8894          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8895 ! Explicit gradient in virtual-dihedral angles.
8896         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8897          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8898          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8899         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8900         vv(1)=pizda(1,1)-pizda(2,2)
8901         vv(2)=pizda(1,2)+pizda(2,1)
8902         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8903          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8904          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8905         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8906         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8907         vv(1)=pizda(1,1)-pizda(2,2)
8908         vv(2)=pizda(1,2)+pizda(2,1)
8909         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8910          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8911          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8912 ! Cartesian gradient
8913         do iii=1,2
8914           do kkk=1,5
8915             do lll=1,3
8916               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8917                 pizda(1,1))
8918               vv(1)=pizda(1,1)-pizda(2,2)
8919               vv(2)=pizda(1,2)+pizda(2,1)
8920               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8921                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8922                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8923             enddo
8924           enddo
8925         enddo
8926 !d        goto 1112
8927 ! Contribution from graph IV
8928 !d1110    continue
8929         call transpose2(EE(1,1,itl),auxmat(1,1))
8930         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8931         vv(1)=pizda(1,1)+pizda(2,2)
8932         vv(2)=pizda(2,1)-pizda(1,2)
8933         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8934          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8935 ! Explicit gradient in virtual-dihedral angles.
8936         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8937          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8938         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8939         vv(1)=pizda(1,1)+pizda(2,2)
8940         vv(2)=pizda(2,1)-pizda(1,2)
8941         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8942          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
8943          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8944 ! Cartesian gradient
8945         do iii=1,2
8946           do kkk=1,5
8947             do lll=1,3
8948               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8949                 pizda(1,1))
8950               vv(1)=pizda(1,1)+pizda(2,2)
8951               vv(2)=pizda(2,1)-pizda(1,2)
8952               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8953                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
8954                -0.5d0*scalar2(vv(1),Ctobr(1,l))
8955             enddo
8956           enddo
8957         enddo
8958       else
8959 ! Antiparallel orientation
8960 ! Contribution from graph III
8961 !        goto 1110
8962         call transpose2(EUg(1,1,j),auxmat(1,1))
8963         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8964         vv(1)=pizda(1,1)-pizda(2,2)
8965         vv(2)=pizda(1,2)+pizda(2,1)
8966         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
8967          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8968 ! Explicit gradient in virtual-dihedral angles.
8969         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8970          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
8971          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
8972         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8973         vv(1)=pizda(1,1)-pizda(2,2)
8974         vv(2)=pizda(1,2)+pizda(2,1)
8975         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8976          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
8977          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8978         call transpose2(EUgder(1,1,j),auxmat1(1,1))
8979         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8980         vv(1)=pizda(1,1)-pizda(2,2)
8981         vv(2)=pizda(1,2)+pizda(2,1)
8982         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8983          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
8984          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
8985 ! Cartesian gradient
8986         do iii=1,2
8987           do kkk=1,5
8988             do lll=1,3
8989               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8990                 pizda(1,1))
8991               vv(1)=pizda(1,1)-pizda(2,2)
8992               vv(2)=pizda(1,2)+pizda(2,1)
8993               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
8994                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
8995                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
8996             enddo
8997           enddo
8998         enddo
8999 !d        goto 1112
9000 ! Contribution from graph IV
9001 1110    continue
9002         call transpose2(EE(1,1,itj),auxmat(1,1))
9003         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9004         vv(1)=pizda(1,1)+pizda(2,2)
9005         vv(2)=pizda(2,1)-pizda(1,2)
9006         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9007          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9008 ! Explicit gradient in virtual-dihedral angles.
9009         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9010          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9011         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9012         vv(1)=pizda(1,1)+pizda(2,2)
9013         vv(2)=pizda(2,1)-pizda(1,2)
9014         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9015          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9016          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9017 ! Cartesian gradient
9018         do iii=1,2
9019           do kkk=1,5
9020             do lll=1,3
9021               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9022                 pizda(1,1))
9023               vv(1)=pizda(1,1)+pizda(2,2)
9024               vv(2)=pizda(2,1)-pizda(1,2)
9025               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9026                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9027                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9028             enddo
9029           enddo
9030         enddo
9031       endif
9032 1112  continue
9033       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9034 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9035 !d        write (2,*) 'ijkl',i,j,k,l
9036 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9037 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9038 !d      endif
9039 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9040 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9041 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9042 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9043       if (j.lt.nres-1) then
9044         j1=j+1
9045         j2=j-1
9046       else
9047         j1=j-1
9048         j2=j-2
9049       endif
9050       if (l.lt.nres-1) then
9051         l1=l+1
9052         l2=l-1
9053       else
9054         l1=l-1
9055         l2=l-2
9056       endif
9057 !d      eij=1.0d0
9058 !d      ekl=1.0d0
9059 !d      ekont=1.0d0
9060 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9061 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9062 !        summed up outside the subrouine as for the other subroutines
9063 !        handling long-range interactions. The old code is commented out
9064 !        with "cgrad" to keep track of changes.
9065       do ll=1,3
9066 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9067 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9068         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9069         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9070 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9071 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9072 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9073 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9074 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9075 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9076 !     &   gradcorr5ij,
9077 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9078 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9079 !grad        ghalf=0.5d0*ggg1(ll)
9080 !d        ghalf=0.0d0
9081         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9082         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9083         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9084         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9085         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9086         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9087 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9088 !grad        ghalf=0.5d0*ggg2(ll)
9089         ghalf=0.0d0
9090         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9091         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9092         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9093         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9094         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9095         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9096       enddo
9097 !d      goto 1112
9098 !grad      do m=i+1,j-1
9099 !grad        do ll=1,3
9100 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9101 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9102 !grad        enddo
9103 !grad      enddo
9104 !grad      do m=k+1,l-1
9105 !grad        do ll=1,3
9106 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9107 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9108 !grad        enddo
9109 !grad      enddo
9110 !1112  continue
9111 !grad      do m=i+2,j2
9112 !grad        do ll=1,3
9113 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9114 !grad        enddo
9115 !grad      enddo
9116 !grad      do m=k+2,l2
9117 !grad        do ll=1,3
9118 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9119 !grad        enddo
9120 !grad      enddo
9121 !d      do iii=1,nres-3
9122 !d        write (2,*) iii,g_corr5_loc(iii)
9123 !d      enddo
9124       eello5=ekont*eel5
9125 !d      write (2,*) 'ekont',ekont
9126 !d      write (iout,*) 'eello5',ekont*eel5
9127       return
9128       end function eello5
9129 !-----------------------------------------------------------------------------
9130       real(kind=8) function eello6(i,j,k,l,jj,kk)
9131 !      implicit real*8 (a-h,o-z)
9132 !      include 'DIMENSIONS'
9133 !      include 'COMMON.IOUNITS'
9134 !      include 'COMMON.CHAIN'
9135 !      include 'COMMON.DERIV'
9136 !      include 'COMMON.INTERACT'
9137 !      include 'COMMON.CONTACTS'
9138 !      include 'COMMON.TORSION'
9139 !      include 'COMMON.VAR'
9140 !      include 'COMMON.GEO'
9141 !      include 'COMMON.FFIELD'
9142       real(kind=8),dimension(3) :: ggg1,ggg2
9143       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9144                    eello6_6,eel6
9145       real(kind=8) :: gradcorr6ij,gradcorr6kl
9146       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9147 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9148 !d        eello6=0.0d0
9149 !d        return
9150 !d      endif
9151 !d      write (iout,*)
9152 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9153 !d     &   ' and',k,l
9154       eello6_1=0.0d0
9155       eello6_2=0.0d0
9156       eello6_3=0.0d0
9157       eello6_4=0.0d0
9158       eello6_5=0.0d0
9159       eello6_6=0.0d0
9160 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9161 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9162       do iii=1,2
9163         do kkk=1,5
9164           do lll=1,3
9165             derx(lll,kkk,iii)=0.0d0
9166           enddo
9167         enddo
9168       enddo
9169 !d      eij=facont_hb(jj,i)
9170 !d      ekl=facont_hb(kk,k)
9171 !d      ekont=eij*ekl
9172 !d      eij=1.0d0
9173 !d      ekl=1.0d0
9174 !d      ekont=1.0d0
9175       if (l.eq.j+1) then
9176         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9177         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9178         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9179         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9180         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9181         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9182       else
9183         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9184         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9185         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9186         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9187         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9188           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9189         else
9190           eello6_5=0.0d0
9191         endif
9192         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9193       endif
9194 ! If turn contributions are considered, they will be handled separately.
9195       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9196 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9197 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9198 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9199 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9200 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9201 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9202 !d      goto 1112
9203       if (j.lt.nres-1) then
9204         j1=j+1
9205         j2=j-1
9206       else
9207         j1=j-1
9208         j2=j-2
9209       endif
9210       if (l.lt.nres-1) then
9211         l1=l+1
9212         l2=l-1
9213       else
9214         l1=l-1
9215         l2=l-2
9216       endif
9217       do ll=1,3
9218 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9219 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9220 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9221 !grad        ghalf=0.5d0*ggg1(ll)
9222 !d        ghalf=0.0d0
9223         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9224         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9225         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9226         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9227         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9228         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9229         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9230         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9231 !grad        ghalf=0.5d0*ggg2(ll)
9232 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9233 !d        ghalf=0.0d0
9234         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9235         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9236         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9237         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9238         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9239         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9240       enddo
9241 !d      goto 1112
9242 !grad      do m=i+1,j-1
9243 !grad        do ll=1,3
9244 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9245 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9246 !grad        enddo
9247 !grad      enddo
9248 !grad      do m=k+1,l-1
9249 !grad        do ll=1,3
9250 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9251 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9252 !grad        enddo
9253 !grad      enddo
9254 !grad1112  continue
9255 !grad      do m=i+2,j2
9256 !grad        do ll=1,3
9257 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9258 !grad        enddo
9259 !grad      enddo
9260 !grad      do m=k+2,l2
9261 !grad        do ll=1,3
9262 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9263 !grad        enddo
9264 !grad      enddo
9265 !d      do iii=1,nres-3
9266 !d        write (2,*) iii,g_corr6_loc(iii)
9267 !d      enddo
9268       eello6=ekont*eel6
9269 !d      write (2,*) 'ekont',ekont
9270 !d      write (iout,*) 'eello6',ekont*eel6
9271       return
9272       end function eello6
9273 !-----------------------------------------------------------------------------
9274       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9275       use comm_kut
9276 !      implicit real*8 (a-h,o-z)
9277 !      include 'DIMENSIONS'
9278 !      include 'COMMON.IOUNITS'
9279 !      include 'COMMON.CHAIN'
9280 !      include 'COMMON.DERIV'
9281 !      include 'COMMON.INTERACT'
9282 !      include 'COMMON.CONTACTS'
9283 !      include 'COMMON.TORSION'
9284 !      include 'COMMON.VAR'
9285 !      include 'COMMON.GEO'
9286       real(kind=8),dimension(2) :: vv,vv1
9287       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9288       logical :: swap
9289 !el      logical :: lprn
9290 !el      common /kutas/ lprn
9291       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9292       real(kind=8) :: s1,s2,s3,s4,s5
9293 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9294 !                                                                              C
9295 !      Parallel       Antiparallel                                             C
9296 !                                                                              C
9297 !          o             o                                                     C
9298 !         /l\           /j\                                                    C
9299 !        /   \         /   \                                                   C
9300 !       /| o |         | o |\                                                  C
9301 !     \ j|/k\|  /   \  |/k\|l /                                                C
9302 !      \ /   \ /     \ /   \ /                                                 C
9303 !       o     o       o     o                                                  C
9304 !       i             i                                                        C
9305 !                                                                              C
9306 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9307       itk=itortyp(itype(k,1))
9308       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9309       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9310       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9311       call transpose2(EUgC(1,1,k),auxmat(1,1))
9312       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9313       vv1(1)=pizda1(1,1)-pizda1(2,2)
9314       vv1(2)=pizda1(1,2)+pizda1(2,1)
9315       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9316       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9317       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9318       s5=scalar2(vv(1),Dtobr2(1,i))
9319 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9320       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9321       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9322        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9323        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9324        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9325        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9326        +scalar2(vv(1),Dtobr2der(1,i)))
9327       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9328       vv1(1)=pizda1(1,1)-pizda1(2,2)
9329       vv1(2)=pizda1(1,2)+pizda1(2,1)
9330       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9331       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9332       if (l.eq.j+1) then
9333         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9334        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9335        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9336        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9337        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9338       else
9339         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9340        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9341        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9342        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9343        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9344       endif
9345       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9346       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9347       vv1(1)=pizda1(1,1)-pizda1(2,2)
9348       vv1(2)=pizda1(1,2)+pizda1(2,1)
9349       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9350        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9351        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9352        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9353       do iii=1,2
9354         if (swap) then
9355           ind=3-iii
9356         else
9357           ind=iii
9358         endif
9359         do kkk=1,5
9360           do lll=1,3
9361             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9362             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9363             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9364             call transpose2(EUgC(1,1,k),auxmat(1,1))
9365             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9366               pizda1(1,1))
9367             vv1(1)=pizda1(1,1)-pizda1(2,2)
9368             vv1(2)=pizda1(1,2)+pizda1(2,1)
9369             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9370             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9371              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9372             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9373              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9374             s5=scalar2(vv(1),Dtobr2(1,i))
9375             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9376           enddo
9377         enddo
9378       enddo
9379       return
9380       end function eello6_graph1
9381 !-----------------------------------------------------------------------------
9382       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9383       use comm_kut
9384 !      implicit real*8 (a-h,o-z)
9385 !      include 'DIMENSIONS'
9386 !      include 'COMMON.IOUNITS'
9387 !      include 'COMMON.CHAIN'
9388 !      include 'COMMON.DERIV'
9389 !      include 'COMMON.INTERACT'
9390 !      include 'COMMON.CONTACTS'
9391 !      include 'COMMON.TORSION'
9392 !      include 'COMMON.VAR'
9393 !      include 'COMMON.GEO'
9394       logical :: swap
9395       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9396       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9397 !el      logical :: lprn
9398 !el      common /kutas/ lprn
9399       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9400       real(kind=8) :: s2,s3,s4
9401 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9402 !                                                                              C
9403 !      Parallel       Antiparallel                                             C
9404 !                                                                              C
9405 !          o             o                                                     C
9406 !     \   /l\           /j\   /                                                C
9407 !      \ /   \         /   \ /                                                 C
9408 !       o| o |         | o |o                                                  C
9409 !     \ j|/k\|      \  |/k\|l                                                  C
9410 !      \ /   \       \ /   \                                                   C
9411 !       o             o                                                        C
9412 !       i             i                                                        C
9413 !                                                                              C
9414 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9415 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9416 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9417 !           but not in a cluster cumulant
9418 #ifdef MOMENT
9419       s1=dip(1,jj,i)*dip(1,kk,k)
9420 #endif
9421       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9422       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9423       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9424       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9425       call transpose2(EUg(1,1,k),auxmat(1,1))
9426       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9427       vv(1)=pizda(1,1)-pizda(2,2)
9428       vv(2)=pizda(1,2)+pizda(2,1)
9429       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9430 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9431 #ifdef MOMENT
9432       eello6_graph2=-(s1+s2+s3+s4)
9433 #else
9434       eello6_graph2=-(s2+s3+s4)
9435 #endif
9436 !      eello6_graph2=-s3
9437 ! Derivatives in gamma(i-1)
9438       if (i.gt.1) then
9439 #ifdef MOMENT
9440         s1=dipderg(1,jj,i)*dip(1,kk,k)
9441 #endif
9442         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9443         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9444         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9445         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9446 #ifdef MOMENT
9447         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9448 #else
9449         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9450 #endif
9451 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9452       endif
9453 ! Derivatives in gamma(k-1)
9454 #ifdef MOMENT
9455       s1=dip(1,jj,i)*dipderg(1,kk,k)
9456 #endif
9457       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9458       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9459       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9460       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9461       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9462       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9463       vv(1)=pizda(1,1)-pizda(2,2)
9464       vv(2)=pizda(1,2)+pizda(2,1)
9465       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9466 #ifdef MOMENT
9467       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9468 #else
9469       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9470 #endif
9471 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9472 ! Derivatives in gamma(j-1) or gamma(l-1)
9473       if (j.gt.1) then
9474 #ifdef MOMENT
9475         s1=dipderg(3,jj,i)*dip(1,kk,k)
9476 #endif
9477         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9478         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9479         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9480         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9481         vv(1)=pizda(1,1)-pizda(2,2)
9482         vv(2)=pizda(1,2)+pizda(2,1)
9483         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9484 #ifdef MOMENT
9485         if (swap) then
9486           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9487         else
9488           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9489         endif
9490 #endif
9491         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9492 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9493       endif
9494 ! Derivatives in gamma(l-1) or gamma(j-1)
9495       if (l.gt.1) then
9496 #ifdef MOMENT
9497         s1=dip(1,jj,i)*dipderg(3,kk,k)
9498 #endif
9499         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9500         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9501         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9502         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9503         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9504         vv(1)=pizda(1,1)-pizda(2,2)
9505         vv(2)=pizda(1,2)+pizda(2,1)
9506         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9507 #ifdef MOMENT
9508         if (swap) then
9509           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9510         else
9511           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9512         endif
9513 #endif
9514         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9515 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9516       endif
9517 ! Cartesian derivatives.
9518       if (lprn) then
9519         write (2,*) 'In eello6_graph2'
9520         do iii=1,2
9521           write (2,*) 'iii=',iii
9522           do kkk=1,5
9523             write (2,*) 'kkk=',kkk
9524             do jjj=1,2
9525               write (2,'(3(2f10.5),5x)') &
9526               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9527             enddo
9528           enddo
9529         enddo
9530       endif
9531       do iii=1,2
9532         do kkk=1,5
9533           do lll=1,3
9534 #ifdef MOMENT
9535             if (iii.eq.1) then
9536               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9537             else
9538               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9539             endif
9540 #endif
9541             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9542               auxvec(1))
9543             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9544             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9545               auxvec(1))
9546             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9547             call transpose2(EUg(1,1,k),auxmat(1,1))
9548             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9549               pizda(1,1))
9550             vv(1)=pizda(1,1)-pizda(2,2)
9551             vv(2)=pizda(1,2)+pizda(2,1)
9552             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9553 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9554 #ifdef MOMENT
9555             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9556 #else
9557             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9558 #endif
9559             if (swap) then
9560               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9561             else
9562               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9563             endif
9564           enddo
9565         enddo
9566       enddo
9567       return
9568       end function eello6_graph2
9569 !-----------------------------------------------------------------------------
9570       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9571 !      implicit real*8 (a-h,o-z)
9572 !      include 'DIMENSIONS'
9573 !      include 'COMMON.IOUNITS'
9574 !      include 'COMMON.CHAIN'
9575 !      include 'COMMON.DERIV'
9576 !      include 'COMMON.INTERACT'
9577 !      include 'COMMON.CONTACTS'
9578 !      include 'COMMON.TORSION'
9579 !      include 'COMMON.VAR'
9580 !      include 'COMMON.GEO'
9581       real(kind=8),dimension(2) :: vv,auxvec
9582       real(kind=8),dimension(2,2) :: pizda,auxmat
9583       logical :: swap
9584       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9585       real(kind=8) :: s1,s2,s3,s4
9586 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9587 !                                                                              C
9588 !      Parallel       Antiparallel                                             C
9589 !                                                                              C
9590 !          o             o                                                     C
9591 !         /l\   /   \   /j\                                                    C
9592 !        /   \ /     \ /   \                                                   C
9593 !       /| o |o       o| o |\                                                  C
9594 !       j|/k\|  /      |/k\|l /                                                C
9595 !        /   \ /       /   \ /                                                 C
9596 !       /     o       /     o                                                  C
9597 !       i             i                                                        C
9598 !                                                                              C
9599 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9600 !
9601 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9602 !           energy moment and not to the cluster cumulant.
9603       iti=itortyp(itype(i,1))
9604       if (j.lt.nres-1) then
9605         itj1=itortyp(itype(j+1,1))
9606       else
9607         itj1=ntortyp+1
9608       endif
9609       itk=itortyp(itype(k,1))
9610       itk1=itortyp(itype(k+1,1))
9611       if (l.lt.nres-1) then
9612         itl1=itortyp(itype(l+1,1))
9613       else
9614         itl1=ntortyp+1
9615       endif
9616 #ifdef MOMENT
9617       s1=dip(4,jj,i)*dip(4,kk,k)
9618 #endif
9619       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9620       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9621       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9622       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9623       call transpose2(EE(1,1,itk),auxmat(1,1))
9624       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9625       vv(1)=pizda(1,1)+pizda(2,2)
9626       vv(2)=pizda(2,1)-pizda(1,2)
9627       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9628 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9629 !d     & "sum",-(s2+s3+s4)
9630 #ifdef MOMENT
9631       eello6_graph3=-(s1+s2+s3+s4)
9632 #else
9633       eello6_graph3=-(s2+s3+s4)
9634 #endif
9635 !      eello6_graph3=-s4
9636 ! Derivatives in gamma(k-1)
9637       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9638       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9639       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9640       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9641 ! Derivatives in gamma(l-1)
9642       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9643       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9644       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9645       vv(1)=pizda(1,1)+pizda(2,2)
9646       vv(2)=pizda(2,1)-pizda(1,2)
9647       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9648       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9649 ! Cartesian derivatives.
9650       do iii=1,2
9651         do kkk=1,5
9652           do lll=1,3
9653 #ifdef MOMENT
9654             if (iii.eq.1) then
9655               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9656             else
9657               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9658             endif
9659 #endif
9660             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9661               auxvec(1))
9662             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9663             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9664               auxvec(1))
9665             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9666             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9667               pizda(1,1))
9668             vv(1)=pizda(1,1)+pizda(2,2)
9669             vv(2)=pizda(2,1)-pizda(1,2)
9670             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9671 #ifdef MOMENT
9672             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9673 #else
9674             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9675 #endif
9676             if (swap) then
9677               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9678             else
9679               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9680             endif
9681 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9682           enddo
9683         enddo
9684       enddo
9685       return
9686       end function eello6_graph3
9687 !-----------------------------------------------------------------------------
9688       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9689 !      implicit real*8 (a-h,o-z)
9690 !      include 'DIMENSIONS'
9691 !      include 'COMMON.IOUNITS'
9692 !      include 'COMMON.CHAIN'
9693 !      include 'COMMON.DERIV'
9694 !      include 'COMMON.INTERACT'
9695 !      include 'COMMON.CONTACTS'
9696 !      include 'COMMON.TORSION'
9697 !      include 'COMMON.VAR'
9698 !      include 'COMMON.GEO'
9699 !      include 'COMMON.FFIELD'
9700       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9701       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9702       logical :: swap
9703       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9704               iii,kkk,lll
9705       real(kind=8) :: s1,s2,s3,s4
9706 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9707 !                                                                              C
9708 !      Parallel       Antiparallel                                             C
9709 !                                                                              C
9710 !          o             o                                                     C
9711 !         /l\   /   \   /j\                                                    C
9712 !        /   \ /     \ /   \                                                   C
9713 !       /| o |o       o| o |\                                                  C
9714 !     \ j|/k\|      \  |/k\|l                                                  C
9715 !      \ /   \       \ /   \                                                   C
9716 !       o     \       o     \                                                  C
9717 !       i             i                                                        C
9718 !                                                                              C
9719 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9720 !
9721 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9722 !           energy moment and not to the cluster cumulant.
9723 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9724       iti=itortyp(itype(i,1))
9725       itj=itortyp(itype(j,1))
9726       if (j.lt.nres-1) then
9727         itj1=itortyp(itype(j+1,1))
9728       else
9729         itj1=ntortyp+1
9730       endif
9731       itk=itortyp(itype(k,1))
9732       if (k.lt.nres-1) then
9733         itk1=itortyp(itype(k+1,1))
9734       else
9735         itk1=ntortyp+1
9736       endif
9737       itl=itortyp(itype(l,1))
9738       if (l.lt.nres-1) then
9739         itl1=itortyp(itype(l+1,1))
9740       else
9741         itl1=ntortyp+1
9742       endif
9743 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9744 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9745 !d     & ' itl',itl,' itl1',itl1
9746 #ifdef MOMENT
9747       if (imat.eq.1) then
9748         s1=dip(3,jj,i)*dip(3,kk,k)
9749       else
9750         s1=dip(2,jj,j)*dip(2,kk,l)
9751       endif
9752 #endif
9753       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9754       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9755       if (j.eq.l+1) then
9756         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9757         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9758       else
9759         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9760         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9761       endif
9762       call transpose2(EUg(1,1,k),auxmat(1,1))
9763       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9764       vv(1)=pizda(1,1)-pizda(2,2)
9765       vv(2)=pizda(2,1)+pizda(1,2)
9766       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9767 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9768 #ifdef MOMENT
9769       eello6_graph4=-(s1+s2+s3+s4)
9770 #else
9771       eello6_graph4=-(s2+s3+s4)
9772 #endif
9773 ! Derivatives in gamma(i-1)
9774       if (i.gt.1) then
9775 #ifdef MOMENT
9776         if (imat.eq.1) then
9777           s1=dipderg(2,jj,i)*dip(3,kk,k)
9778         else
9779           s1=dipderg(4,jj,j)*dip(2,kk,l)
9780         endif
9781 #endif
9782         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9783         if (j.eq.l+1) then
9784           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9785           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9786         else
9787           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9788           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9789         endif
9790         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9791         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9792 !d          write (2,*) 'turn6 derivatives'
9793 #ifdef MOMENT
9794           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9795 #else
9796           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9797 #endif
9798         else
9799 #ifdef MOMENT
9800           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9801 #else
9802           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9803 #endif
9804         endif
9805       endif
9806 ! Derivatives in gamma(k-1)
9807 #ifdef MOMENT
9808       if (imat.eq.1) then
9809         s1=dip(3,jj,i)*dipderg(2,kk,k)
9810       else
9811         s1=dip(2,jj,j)*dipderg(4,kk,l)
9812       endif
9813 #endif
9814       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9815       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9816       if (j.eq.l+1) then
9817         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9818         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9819       else
9820         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9821         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9822       endif
9823       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9824       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9825       vv(1)=pizda(1,1)-pizda(2,2)
9826       vv(2)=pizda(2,1)+pizda(1,2)
9827       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9828       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9829 #ifdef MOMENT
9830         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9831 #else
9832         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9833 #endif
9834       else
9835 #ifdef MOMENT
9836         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9837 #else
9838         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9839 #endif
9840       endif
9841 ! Derivatives in gamma(j-1) or gamma(l-1)
9842       if (l.eq.j+1 .and. l.gt.1) then
9843         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9844         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9845         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9846         vv(1)=pizda(1,1)-pizda(2,2)
9847         vv(2)=pizda(2,1)+pizda(1,2)
9848         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9849         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9850       else if (j.gt.1) then
9851         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9852         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9853         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9854         vv(1)=pizda(1,1)-pizda(2,2)
9855         vv(2)=pizda(2,1)+pizda(1,2)
9856         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9857         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9858           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9859         else
9860           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9861         endif
9862       endif
9863 ! Cartesian derivatives.
9864       do iii=1,2
9865         do kkk=1,5
9866           do lll=1,3
9867 #ifdef MOMENT
9868             if (iii.eq.1) then
9869               if (imat.eq.1) then
9870                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9871               else
9872                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9873               endif
9874             else
9875               if (imat.eq.1) then
9876                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9877               else
9878                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9879               endif
9880             endif
9881 #endif
9882             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9883               auxvec(1))
9884             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9885             if (j.eq.l+1) then
9886               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9887                 b1(1,itj1),auxvec(1))
9888               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9889             else
9890               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9891                 b1(1,itl1),auxvec(1))
9892               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9893             endif
9894             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9895               pizda(1,1))
9896             vv(1)=pizda(1,1)-pizda(2,2)
9897             vv(2)=pizda(2,1)+pizda(1,2)
9898             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9899             if (swap) then
9900               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9901 #ifdef MOMENT
9902                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9903                    -(s1+s2+s4)
9904 #else
9905                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9906                    -(s2+s4)
9907 #endif
9908                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9909               else
9910 #ifdef MOMENT
9911                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9912 #else
9913                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9914 #endif
9915                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9916               endif
9917             else
9918 #ifdef MOMENT
9919               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9920 #else
9921               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9922 #endif
9923               if (l.eq.j+1) then
9924                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9925               else
9926                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9927               endif
9928             endif
9929           enddo
9930         enddo
9931       enddo
9932       return
9933       end function eello6_graph4
9934 !-----------------------------------------------------------------------------
9935       real(kind=8) function eello_turn6(i,jj,kk)
9936 !      implicit real*8 (a-h,o-z)
9937 !      include 'DIMENSIONS'
9938 !      include 'COMMON.IOUNITS'
9939 !      include 'COMMON.CHAIN'
9940 !      include 'COMMON.DERIV'
9941 !      include 'COMMON.INTERACT'
9942 !      include 'COMMON.CONTACTS'
9943 !      include 'COMMON.TORSION'
9944 !      include 'COMMON.VAR'
9945 !      include 'COMMON.GEO'
9946       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
9947       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
9948       real(kind=8),dimension(3) :: ggg1,ggg2
9949       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
9950       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
9951 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9952 !           the respective energy moment and not to the cluster cumulant.
9953 !el local variables
9954       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
9955       integer :: j1,j2,l1,l2,ll
9956       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
9957       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
9958       s1=0.0d0
9959       s8=0.0d0
9960       s13=0.0d0
9961 !
9962       eello_turn6=0.0d0
9963       j=i+4
9964       k=i+1
9965       l=i+3
9966       iti=itortyp(itype(i,1))
9967       itk=itortyp(itype(k,1))
9968       itk1=itortyp(itype(k+1,1))
9969       itl=itortyp(itype(l,1))
9970       itj=itortyp(itype(j,1))
9971 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
9972 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
9973 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9974 !d        eello6=0.0d0
9975 !d        return
9976 !d      endif
9977 !d      write (iout,*)
9978 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9979 !d     &   ' and',k,l
9980 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
9981       do iii=1,2
9982         do kkk=1,5
9983           do lll=1,3
9984             derx_turn(lll,kkk,iii)=0.0d0
9985           enddo
9986         enddo
9987       enddo
9988 !d      eij=1.0d0
9989 !d      ekl=1.0d0
9990 !d      ekont=1.0d0
9991       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9992 !d      eello6_5=0.0d0
9993 !d      write (2,*) 'eello6_5',eello6_5
9994 #ifdef MOMENT
9995       call transpose2(AEA(1,1,1),auxmat(1,1))
9996       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
9997       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
9998       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
9999 #endif
10000       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10001       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10002       s2 = scalar2(b1(1,itk),vtemp1(1))
10003 #ifdef MOMENT
10004       call transpose2(AEA(1,1,2),atemp(1,1))
10005       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10006       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10007       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10008 #endif
10009       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10010       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10011       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10012 #ifdef MOMENT
10013       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10014       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10015       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10016       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10017       ss13 = scalar2(b1(1,itk),vtemp4(1))
10018       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10019 #endif
10020 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10021 !      s1=0.0d0
10022 !      s2=0.0d0
10023 !      s8=0.0d0
10024 !      s12=0.0d0
10025 !      s13=0.0d0
10026       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10027 ! Derivatives in gamma(i+2)
10028       s1d =0.0d0
10029       s8d =0.0d0
10030 #ifdef MOMENT
10031       call transpose2(AEA(1,1,1),auxmatd(1,1))
10032       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10033       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10034       call transpose2(AEAderg(1,1,2),atempd(1,1))
10035       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10036       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10037 #endif
10038       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10039       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10040       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10041 !      s1d=0.0d0
10042 !      s2d=0.0d0
10043 !      s8d=0.0d0
10044 !      s12d=0.0d0
10045 !      s13d=0.0d0
10046       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10047 ! Derivatives in gamma(i+3)
10048 #ifdef MOMENT
10049       call transpose2(AEA(1,1,1),auxmatd(1,1))
10050       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10051       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10052       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10053 #endif
10054       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10055       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10056       s2d = scalar2(b1(1,itk),vtemp1d(1))
10057 #ifdef MOMENT
10058       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10059       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10060 #endif
10061       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10062 #ifdef MOMENT
10063       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10064       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10065       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10066 #endif
10067 !      s1d=0.0d0
10068 !      s2d=0.0d0
10069 !      s8d=0.0d0
10070 !      s12d=0.0d0
10071 !      s13d=0.0d0
10072 #ifdef MOMENT
10073       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10074                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10075 #else
10076       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10077                     -0.5d0*ekont*(s2d+s12d)
10078 #endif
10079 ! Derivatives in gamma(i+4)
10080       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10081       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10082       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10083 #ifdef MOMENT
10084       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10085       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10086       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10087 #endif
10088 !      s1d=0.0d0
10089 !      s2d=0.0d0
10090 !      s8d=0.0d0
10091 !      s12d=0.0d0
10092 !      s13d=0.0d0
10093 #ifdef MOMENT
10094       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10095 #else
10096       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10097 #endif
10098 ! Derivatives in gamma(i+5)
10099 #ifdef MOMENT
10100       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10101       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10102       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10103 #endif
10104       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10105       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10106       s2d = scalar2(b1(1,itk),vtemp1d(1))
10107 #ifdef MOMENT
10108       call transpose2(AEA(1,1,2),atempd(1,1))
10109       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10110       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10111 #endif
10112       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10113       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10114 #ifdef MOMENT
10115       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10116       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10117       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10118 #endif
10119 !      s1d=0.0d0
10120 !      s2d=0.0d0
10121 !      s8d=0.0d0
10122 !      s12d=0.0d0
10123 !      s13d=0.0d0
10124 #ifdef MOMENT
10125       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10126                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10127 #else
10128       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10129                     -0.5d0*ekont*(s2d+s12d)
10130 #endif
10131 ! Cartesian derivatives
10132       do iii=1,2
10133         do kkk=1,5
10134           do lll=1,3
10135 #ifdef MOMENT
10136             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10137             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10138             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10139 #endif
10140             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10141             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10142                 vtemp1d(1))
10143             s2d = scalar2(b1(1,itk),vtemp1d(1))
10144 #ifdef MOMENT
10145             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10146             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10147             s8d = -(atempd(1,1)+atempd(2,2))* &
10148                  scalar2(cc(1,1,itl),vtemp2(1))
10149 #endif
10150             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10151                  auxmatd(1,1))
10152             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10153             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10154 !      s1d=0.0d0
10155 !      s2d=0.0d0
10156 !      s8d=0.0d0
10157 !      s12d=0.0d0
10158 !      s13d=0.0d0
10159 #ifdef MOMENT
10160             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10161               - 0.5d0*(s1d+s2d)
10162 #else
10163             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10164               - 0.5d0*s2d
10165 #endif
10166 #ifdef MOMENT
10167             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10168               - 0.5d0*(s8d+s12d)
10169 #else
10170             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10171               - 0.5d0*s12d
10172 #endif
10173           enddo
10174         enddo
10175       enddo
10176 #ifdef MOMENT
10177       do kkk=1,5
10178         do lll=1,3
10179           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10180             achuj_tempd(1,1))
10181           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10182           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10183           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10184           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10185           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10186             vtemp4d(1))
10187           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10188           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10189           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10190         enddo
10191       enddo
10192 #endif
10193 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10194 !d     &  16*eel_turn6_num
10195 !d      goto 1112
10196       if (j.lt.nres-1) then
10197         j1=j+1
10198         j2=j-1
10199       else
10200         j1=j-1
10201         j2=j-2
10202       endif
10203       if (l.lt.nres-1) then
10204         l1=l+1
10205         l2=l-1
10206       else
10207         l1=l-1
10208         l2=l-2
10209       endif
10210       do ll=1,3
10211 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10212 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10213 !grad        ghalf=0.5d0*ggg1(ll)
10214 !d        ghalf=0.0d0
10215         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10216         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10217         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10218           +ekont*derx_turn(ll,2,1)
10219         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10220         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10221           +ekont*derx_turn(ll,4,1)
10222         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10223         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10224         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10225 !grad        ghalf=0.5d0*ggg2(ll)
10226 !d        ghalf=0.0d0
10227         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10228           +ekont*derx_turn(ll,2,2)
10229         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10230         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10231           +ekont*derx_turn(ll,4,2)
10232         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10233         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10234         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10235       enddo
10236 !d      goto 1112
10237 !grad      do m=i+1,j-1
10238 !grad        do ll=1,3
10239 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10240 !grad        enddo
10241 !grad      enddo
10242 !grad      do m=k+1,l-1
10243 !grad        do ll=1,3
10244 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10245 !grad        enddo
10246 !grad      enddo
10247 !grad1112  continue
10248 !grad      do m=i+2,j2
10249 !grad        do ll=1,3
10250 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10251 !grad        enddo
10252 !grad      enddo
10253 !grad      do m=k+2,l2
10254 !grad        do ll=1,3
10255 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10256 !grad        enddo
10257 !grad      enddo
10258 !d      do iii=1,nres-3
10259 !d        write (2,*) iii,g_corr6_loc(iii)
10260 !d      enddo
10261       eello_turn6=ekont*eel_turn6
10262 !d      write (2,*) 'ekont',ekont
10263 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10264       return
10265       end function eello_turn6
10266 !-----------------------------------------------------------------------------
10267       subroutine MATVEC2(A1,V1,V2)
10268 !DIR$ INLINEALWAYS MATVEC2
10269 #ifndef OSF
10270 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10271 #endif
10272 !      implicit real*8 (a-h,o-z)
10273 !      include 'DIMENSIONS'
10274       real(kind=8),dimension(2) :: V1,V2
10275       real(kind=8),dimension(2,2) :: A1
10276       real(kind=8) :: vaux1,vaux2
10277 !      DO 1 I=1,2
10278 !        VI=0.0
10279 !        DO 3 K=1,2
10280 !    3     VI=VI+A1(I,K)*V1(K)
10281 !        Vaux(I)=VI
10282 !    1 CONTINUE
10283
10284       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10285       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10286
10287       v2(1)=vaux1
10288       v2(2)=vaux2
10289       end subroutine MATVEC2
10290 !-----------------------------------------------------------------------------
10291       subroutine MATMAT2(A1,A2,A3)
10292 #ifndef OSF
10293 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10294 #endif
10295 !      implicit real*8 (a-h,o-z)
10296 !      include 'DIMENSIONS'
10297       real(kind=8),dimension(2,2) :: A1,A2,A3
10298       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10299 !      DIMENSION AI3(2,2)
10300 !        DO  J=1,2
10301 !          A3IJ=0.0
10302 !          DO K=1,2
10303 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10304 !          enddo
10305 !          A3(I,J)=A3IJ
10306 !       enddo
10307 !      enddo
10308
10309       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10310       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10311       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10312       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10313
10314       A3(1,1)=AI3_11
10315       A3(2,1)=AI3_21
10316       A3(1,2)=AI3_12
10317       A3(2,2)=AI3_22
10318       end subroutine MATMAT2
10319 !-----------------------------------------------------------------------------
10320       real(kind=8) function scalar2(u,v)
10321 !DIR$ INLINEALWAYS scalar2
10322       implicit none
10323       real(kind=8),dimension(2) :: u,v
10324       real(kind=8) :: sc
10325       integer :: i
10326       scalar2=u(1)*v(1)+u(2)*v(2)
10327       return
10328       end function scalar2
10329 !-----------------------------------------------------------------------------
10330       subroutine transpose2(a,at)
10331 !DIR$ INLINEALWAYS transpose2
10332 #ifndef OSF
10333 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10334 #endif
10335       implicit none
10336       real(kind=8),dimension(2,2) :: a,at
10337       at(1,1)=a(1,1)
10338       at(1,2)=a(2,1)
10339       at(2,1)=a(1,2)
10340       at(2,2)=a(2,2)
10341       return
10342       end subroutine transpose2
10343 !-----------------------------------------------------------------------------
10344       subroutine transpose(n,a,at)
10345       implicit none
10346       integer :: n,i,j
10347       real(kind=8),dimension(n,n) :: a,at
10348       do i=1,n
10349         do j=1,n
10350           at(j,i)=a(i,j)
10351         enddo
10352       enddo
10353       return
10354       end subroutine transpose
10355 !-----------------------------------------------------------------------------
10356       subroutine prodmat3(a1,a2,kk,transp,prod)
10357 !DIR$ INLINEALWAYS prodmat3
10358 #ifndef OSF
10359 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10360 #endif
10361       implicit none
10362       integer :: i,j
10363       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10364       logical :: transp
10365 !rc      double precision auxmat(2,2),prod_(2,2)
10366
10367       if (transp) then
10368 !rc        call transpose2(kk(1,1),auxmat(1,1))
10369 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10370 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10371
10372            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10373        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10374            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10375        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10376            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10377        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10378            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10379        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10380
10381       else
10382 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10383 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10384
10385            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10386         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10387            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10388         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10389            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10390         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10391            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10392         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10393
10394       endif
10395 !      call transpose2(a2(1,1),a2t(1,1))
10396
10397 !rc      print *,transp
10398 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10399 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10400
10401       return
10402       end subroutine prodmat3
10403 !-----------------------------------------------------------------------------
10404 ! energy_p_new_barrier.F
10405 !-----------------------------------------------------------------------------
10406       subroutine sum_gradient
10407 !      implicit real*8 (a-h,o-z)
10408       use io_base, only: pdbout
10409 !      include 'DIMENSIONS'
10410 #ifndef ISNAN
10411       external proc_proc
10412 #ifdef WINPGI
10413 !MS$ATTRIBUTES C ::  proc_proc
10414 #endif
10415 #endif
10416 #ifdef MPI
10417       include 'mpif.h'
10418 #endif
10419       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10420                    gloc_scbuf !(3,maxres)
10421
10422       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10423 !#endif
10424 !el local variables
10425       integer :: i,j,k,ierror,ierr
10426       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10427                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10428                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10429                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10430                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10431                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10432                    gsccorr_max,gsccorrx_max,time00
10433
10434 !      include 'COMMON.SETUP'
10435 !      include 'COMMON.IOUNITS'
10436 !      include 'COMMON.FFIELD'
10437 !      include 'COMMON.DERIV'
10438 !      include 'COMMON.INTERACT'
10439 !      include 'COMMON.SBRIDGE'
10440 !      include 'COMMON.CHAIN'
10441 !      include 'COMMON.VAR'
10442 !      include 'COMMON.CONTROL'
10443 !      include 'COMMON.TIME1'
10444 !      include 'COMMON.MAXGRAD'
10445 !      include 'COMMON.SCCOR'
10446 #ifdef TIMING
10447       time01=MPI_Wtime()
10448 #endif
10449 #ifdef DEBUG
10450       write (iout,*) "sum_gradient gvdwc, gvdwx"
10451       do i=1,nres
10452         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10453          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10454       enddo
10455       call flush(iout)
10456 #endif
10457 #ifdef MPI
10458         gradbufc=0.0d0
10459         gradbufx=0.0d0
10460         gradbufc_sum=0.0d0
10461         gloc_scbuf=0.0d0
10462         glocbuf=0.0d0
10463 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10464         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10465           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10466 #endif
10467 !
10468 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10469 !            in virtual-bond-vector coordinates
10470 !
10471 #ifdef DEBUG
10472 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10473 !      do i=1,nres-1
10474 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10475 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10476 !      enddo
10477 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10478 !      do i=1,nres-1
10479 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10480 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10481 !      enddo
10482       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10483       do i=1,nres
10484         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10485          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10486          (gvdwc_scpp(j,i),j=1,3)
10487       enddo
10488       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10489       do i=1,nres
10490         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10491          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10492          (gelc_loc_long(j,i),j=1,3)
10493       enddo
10494       call flush(iout)
10495 #endif
10496 #ifdef SPLITELE
10497       do i=0,nct
10498         do j=1,3
10499           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10500                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10501                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10502                       wel_loc*gel_loc_long(j,i)+ &
10503                       wcorr*gradcorr_long(j,i)+ &
10504                       wcorr5*gradcorr5_long(j,i)+ &
10505                       wcorr6*gradcorr6_long(j,i)+ &
10506                       wturn6*gcorr6_turn_long(j,i)+ &
10507                       wstrain*ghpbc(j,i) &
10508                      +wliptran*gliptranc(j,i) &
10509                      +gradafm(j,i) &
10510                      +welec*gshieldc(j,i) &
10511                      +wcorr*gshieldc_ec(j,i) &
10512                      +wturn3*gshieldc_t3(j,i)&
10513                      +wturn4*gshieldc_t4(j,i)&
10514                      +wel_loc*gshieldc_ll(j,i)&
10515                      +wtube*gg_tube(j,i) &
10516                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10517                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10518                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10519                      wcorr_nucl*gradcorr_nucl(j,i)&
10520                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10521                      wcatprot* gradpepcat(j,i)+ &
10522                      wcatcat*gradcatcat(j,i)+   &
10523                      wscbase*gvdwc_scbase(j,i)+ &
10524                      wpepbase*gvdwc_pepbase(j,i)+&
10525                      wscpho*gvdwc_scpho(j,i)+   &
10526                      wpeppho*gvdwc_peppho(j,i)
10527
10528
10529
10530
10531
10532         enddo
10533       enddo
10534 #else
10535       do i=0,nct
10536         do j=1,3
10537           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10538                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10539                       welec*gelc_long(j,i)+ &
10540                       wbond*gradb(j,i)+ &
10541                       wel_loc*gel_loc_long(j,i)+ &
10542                       wcorr*gradcorr_long(j,i)+ &
10543                       wcorr5*gradcorr5_long(j,i)+ &
10544                       wcorr6*gradcorr6_long(j,i)+ &
10545                       wturn6*gcorr6_turn_long(j,i)+ &
10546                       wstrain*ghpbc(j,i) &
10547                      +wliptran*gliptranc(j,i) &
10548                      +gradafm(j,i) &
10549                      +welec*gshieldc(j,i)&
10550                      +wcorr*gshieldc_ec(j,i) &
10551                      +wturn4*gshieldc_t4(j,i) &
10552                      +wel_loc*gshieldc_ll(j,i)&
10553                      +wtube*gg_tube(j,i) &
10554                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10555                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10556                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10557                      wcorr_nucl*gradcorr_nucl(j,i) &
10558                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10559                      wcatprot* gradpepcat(j,i)+ &
10560                      wcatcat*gradcatcat(j,i)+   &
10561                      wscbase*gvdwc_scbase(j,i)  &
10562                      wpepbase*gvdwc_pepbase(j,i)+&
10563                      wscpho*gvdwc_scpho(j,i)+&
10564                      wpeppho*gvdwc_peppho(j,i)
10565
10566
10567         enddo
10568       enddo
10569 #endif
10570 #ifdef MPI
10571       if (nfgtasks.gt.1) then
10572       time00=MPI_Wtime()
10573 #ifdef DEBUG
10574       write (iout,*) "gradbufc before allreduce"
10575       do i=1,nres
10576         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10577       enddo
10578       call flush(iout)
10579 #endif
10580       do i=0,nres
10581         do j=1,3
10582           gradbufc_sum(j,i)=gradbufc(j,i)
10583         enddo
10584       enddo
10585 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10586 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10587 !      time_reduce=time_reduce+MPI_Wtime()-time00
10588 #ifdef DEBUG
10589 !      write (iout,*) "gradbufc_sum after allreduce"
10590 !      do i=1,nres
10591 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10592 !      enddo
10593 !      call flush(iout)
10594 #endif
10595 #ifdef TIMING
10596 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10597 #endif
10598       do i=0,nres
10599         do k=1,3
10600           gradbufc(k,i)=0.0d0
10601         enddo
10602       enddo
10603 #ifdef DEBUG
10604       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10605       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10606                         " jgrad_end  ",jgrad_end(i),&
10607                         i=igrad_start,igrad_end)
10608 #endif
10609 !
10610 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10611 ! do not parallelize this part.
10612 !
10613 !      do i=igrad_start,igrad_end
10614 !        do j=jgrad_start(i),jgrad_end(i)
10615 !          do k=1,3
10616 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10617 !          enddo
10618 !        enddo
10619 !      enddo
10620       do j=1,3
10621         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10622       enddo
10623       do i=nres-2,-1,-1
10624         do j=1,3
10625           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10626         enddo
10627       enddo
10628 #ifdef DEBUG
10629       write (iout,*) "gradbufc after summing"
10630       do i=1,nres
10631         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10632       enddo
10633       call flush(iout)
10634 #endif
10635       else
10636 #endif
10637 !el#define DEBUG
10638 #ifdef DEBUG
10639       write (iout,*) "gradbufc"
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 !el#undef DEBUG
10646       do i=-1,nres
10647         do j=1,3
10648           gradbufc_sum(j,i)=gradbufc(j,i)
10649           gradbufc(j,i)=0.0d0
10650         enddo
10651       enddo
10652       do j=1,3
10653         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10654       enddo
10655       do i=nres-2,-1,-1
10656         do j=1,3
10657           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10658         enddo
10659       enddo
10660 !      do i=nnt,nres-1
10661 !        do k=1,3
10662 !          gradbufc(k,i)=0.0d0
10663 !        enddo
10664 !        do j=i+1,nres
10665 !          do k=1,3
10666 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10667 !          enddo
10668 !        enddo
10669 !      enddo
10670 !el#define DEBUG
10671 #ifdef DEBUG
10672       write (iout,*) "gradbufc after summing"
10673       do i=1,nres
10674         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10675       enddo
10676       call flush(iout)
10677 #endif
10678 !el#undef DEBUG
10679 #ifdef MPI
10680       endif
10681 #endif
10682       do k=1,3
10683         gradbufc(k,nres)=0.0d0
10684       enddo
10685 !el----------------
10686 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10687 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10688 !el-----------------
10689       do i=-1,nct
10690         do j=1,3
10691 #ifdef SPLITELE
10692           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10693                       wel_loc*gel_loc(j,i)+ &
10694                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10695                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10696                       wel_loc*gel_loc_long(j,i)+ &
10697                       wcorr*gradcorr_long(j,i)+ &
10698                       wcorr5*gradcorr5_long(j,i)+ &
10699                       wcorr6*gradcorr6_long(j,i)+ &
10700                       wturn6*gcorr6_turn_long(j,i))+ &
10701                       wbond*gradb(j,i)+ &
10702                       wcorr*gradcorr(j,i)+ &
10703                       wturn3*gcorr3_turn(j,i)+ &
10704                       wturn4*gcorr4_turn(j,i)+ &
10705                       wcorr5*gradcorr5(j,i)+ &
10706                       wcorr6*gradcorr6(j,i)+ &
10707                       wturn6*gcorr6_turn(j,i)+ &
10708                       wsccor*gsccorc(j,i) &
10709                      +wscloc*gscloc(j,i)  &
10710                      +wliptran*gliptranc(j,i) &
10711                      +gradafm(j,i) &
10712                      +welec*gshieldc(j,i) &
10713                      +welec*gshieldc_loc(j,i) &
10714                      +wcorr*gshieldc_ec(j,i) &
10715                      +wcorr*gshieldc_loc_ec(j,i) &
10716                      +wturn3*gshieldc_t3(j,i) &
10717                      +wturn3*gshieldc_loc_t3(j,i) &
10718                      +wturn4*gshieldc_t4(j,i) &
10719                      +wturn4*gshieldc_loc_t4(j,i) &
10720                      +wel_loc*gshieldc_ll(j,i) &
10721                      +wel_loc*gshieldc_loc_ll(j,i) &
10722                      +wtube*gg_tube(j,i) &
10723                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10724                      +wvdwpsb*gvdwpsb1(j,i))&
10725                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10726
10727 !                 if ((i.le.2).and.(i.ge.1))
10728 !                       print *,gradc(j,i,icg),&
10729 !                      gradbufc(j,i),welec*gelc(j,i), &
10730 !                      wel_loc*gel_loc(j,i), &
10731 !                      wscp*gvdwc_scpp(j,i), &
10732 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10733 !                      wel_loc*gel_loc_long(j,i), &
10734 !                      wcorr*gradcorr_long(j,i), &
10735 !                      wcorr5*gradcorr5_long(j,i), &
10736 !                      wcorr6*gradcorr6_long(j,i), &
10737 !                      wturn6*gcorr6_turn_long(j,i), &
10738 !                      wbond*gradb(j,i), &
10739 !                      wcorr*gradcorr(j,i), &
10740 !                      wturn3*gcorr3_turn(j,i), &
10741 !                      wturn4*gcorr4_turn(j,i), &
10742 !                      wcorr5*gradcorr5(j,i), &
10743 !                      wcorr6*gradcorr6(j,i), &
10744 !                      wturn6*gcorr6_turn(j,i), &
10745 !                      wsccor*gsccorc(j,i) &
10746 !                     ,wscloc*gscloc(j,i)  &
10747 !                     ,wliptran*gliptranc(j,i) &
10748 !                    ,gradafm(j,i) &
10749 !                     ,welec*gshieldc(j,i) &
10750 !                     ,welec*gshieldc_loc(j,i) &
10751 !                     ,wcorr*gshieldc_ec(j,i) &
10752 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10753 !                     ,wturn3*gshieldc_t3(j,i) &
10754 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10755 !                     ,wturn4*gshieldc_t4(j,i) &
10756 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10757 !                     ,wel_loc*gshieldc_ll(j,i) &
10758 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10759 !                     ,wtube*gg_tube(j,i) &
10760 !                     ,wbond_nucl*gradb_nucl(j,i) &
10761 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10762 !                     wvdwpsb*gvdwpsb1(j,i)&
10763 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10764 !
10765
10766 #else
10767           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10768                       wel_loc*gel_loc(j,i)+ &
10769                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10770                       welec*gelc_long(j,i)+ &
10771                       wel_loc*gel_loc_long(j,i)+ &
10772 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10773                       wcorr5*gradcorr5_long(j,i)+ &
10774                       wcorr6*gradcorr6_long(j,i)+ &
10775                       wturn6*gcorr6_turn_long(j,i))+ &
10776                       wbond*gradb(j,i)+ &
10777                       wcorr*gradcorr(j,i)+ &
10778                       wturn3*gcorr3_turn(j,i)+ &
10779                       wturn4*gcorr4_turn(j,i)+ &
10780                       wcorr5*gradcorr5(j,i)+ &
10781                       wcorr6*gradcorr6(j,i)+ &
10782                       wturn6*gcorr6_turn(j,i)+ &
10783                       wsccor*gsccorc(j,i) &
10784                      +wscloc*gscloc(j,i) &
10785                      +gradafm(j,i) &
10786                      +wliptran*gliptranc(j,i) &
10787                      +welec*gshieldc(j,i) &
10788                      +welec*gshieldc_loc(j,) &
10789                      +wcorr*gshieldc_ec(j,i) &
10790                      +wcorr*gshieldc_loc_ec(j,i) &
10791                      +wturn3*gshieldc_t3(j,i) &
10792                      +wturn3*gshieldc_loc_t3(j,i) &
10793                      +wturn4*gshieldc_t4(j,i) &
10794                      +wturn4*gshieldc_loc_t4(j,i) &
10795                      +wel_loc*gshieldc_ll(j,i) &
10796                      +wel_loc*gshieldc_loc_ll(j,i) &
10797                      +wtube*gg_tube(j,i) &
10798                      +wbond_nucl*gradb_nucl(j,i) &
10799                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10800                      +wvdwpsb*gvdwpsb1(j,i))&
10801                      +wsbloc*gsbloc(j,i)
10802
10803
10804
10805
10806 #endif
10807           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10808                         wbond*gradbx(j,i)+ &
10809                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10810                         wsccor*gsccorx(j,i) &
10811                        +wscloc*gsclocx(j,i) &
10812                        +wliptran*gliptranx(j,i) &
10813                        +welec*gshieldx(j,i)     &
10814                        +wcorr*gshieldx_ec(j,i)  &
10815                        +wturn3*gshieldx_t3(j,i) &
10816                        +wturn4*gshieldx_t4(j,i) &
10817                        +wel_loc*gshieldx_ll(j,i)&
10818                        +wtube*gg_tube_sc(j,i)   &
10819                        +wbond_nucl*gradbx_nucl(j,i) &
10820                        +wvdwsb*gvdwsbx(j,i) &
10821                        +welsb*gelsbx(j,i) &
10822                        +wcorr_nucl*gradxorr_nucl(j,i)&
10823                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10824                        +wsbloc*gsblocx(j,i) &
10825                        +wcatprot* gradpepcatx(j,i)&
10826                        +wscbase*gvdwx_scbase(j,i) &
10827                        +wpepbase*gvdwx_pepbase(j,i)&
10828                        +wscpho*gvdwx_scpho(j,i)
10829 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
10830
10831         enddo
10832       enddo
10833 #ifdef DEBUG
10834       write (iout,*) "gloc before adding corr"
10835       do i=1,4*nres
10836         write (iout,*) i,gloc(i,icg)
10837       enddo
10838 #endif
10839       do i=1,nres-3
10840         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10841          +wcorr5*g_corr5_loc(i) &
10842          +wcorr6*g_corr6_loc(i) &
10843          +wturn4*gel_loc_turn4(i) &
10844          +wturn3*gel_loc_turn3(i) &
10845          +wturn6*gel_loc_turn6(i) &
10846          +wel_loc*gel_loc_loc(i)
10847       enddo
10848 #ifdef DEBUG
10849       write (iout,*) "gloc after adding corr"
10850       do i=1,4*nres
10851         write (iout,*) i,gloc(i,icg)
10852       enddo
10853 #endif
10854 #ifdef MPI
10855       if (nfgtasks.gt.1) then
10856         do j=1,3
10857           do i=0,nres
10858             gradbufc(j,i)=gradc(j,i,icg)
10859             gradbufx(j,i)=gradx(j,i,icg)
10860           enddo
10861         enddo
10862         do i=1,4*nres
10863           glocbuf(i)=gloc(i,icg)
10864         enddo
10865 !#define DEBUG
10866 #ifdef DEBUG
10867       write (iout,*) "gloc_sc before reduce"
10868       do i=1,nres
10869        do j=1,1
10870         write (iout,*) i,j,gloc_sc(j,i,icg)
10871        enddo
10872       enddo
10873 #endif
10874 !#undef DEBUG
10875         do i=1,nres
10876          do j=1,3
10877           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10878          enddo
10879         enddo
10880         time00=MPI_Wtime()
10881         call MPI_Barrier(FG_COMM,IERR)
10882         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10883         time00=MPI_Wtime()
10884         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10885           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10886         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10887           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10888         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10889           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10890         time_reduce=time_reduce+MPI_Wtime()-time00
10891         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10892           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10893         time_reduce=time_reduce+MPI_Wtime()-time00
10894 !#define DEBUG
10895 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10896 #ifdef DEBUG
10897       write (iout,*) "gloc_sc after reduce"
10898       do i=1,nres
10899        do j=1,1
10900         write (iout,*) i,j,gloc_sc(j,i,icg)
10901        enddo
10902       enddo
10903 #endif
10904 !#undef DEBUG
10905 #ifdef DEBUG
10906       write (iout,*) "gloc after reduce"
10907       do i=1,4*nres
10908         write (iout,*) i,gloc(i,icg)
10909       enddo
10910 #endif
10911       endif
10912 #endif
10913       if (gnorm_check) then
10914 !
10915 ! Compute the maximum elements of the gradient
10916 !
10917       gvdwc_max=0.0d0
10918       gvdwc_scp_max=0.0d0
10919       gelc_max=0.0d0
10920       gvdwpp_max=0.0d0
10921       gradb_max=0.0d0
10922       ghpbc_max=0.0d0
10923       gradcorr_max=0.0d0
10924       gel_loc_max=0.0d0
10925       gcorr3_turn_max=0.0d0
10926       gcorr4_turn_max=0.0d0
10927       gradcorr5_max=0.0d0
10928       gradcorr6_max=0.0d0
10929       gcorr6_turn_max=0.0d0
10930       gsccorc_max=0.0d0
10931       gscloc_max=0.0d0
10932       gvdwx_max=0.0d0
10933       gradx_scp_max=0.0d0
10934       ghpbx_max=0.0d0
10935       gradxorr_max=0.0d0
10936       gsccorx_max=0.0d0
10937       gsclocx_max=0.0d0
10938       do i=1,nct
10939         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
10940         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
10941         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
10942         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
10943          gvdwc_scp_max=gvdwc_scp_norm
10944         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
10945         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
10946         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
10947         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
10948         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
10949         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
10950         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
10951         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
10952         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
10953         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
10954         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
10955         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
10956         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
10957           gcorr3_turn(1,i)))
10958         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
10959           gcorr3_turn_max=gcorr3_turn_norm
10960         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
10961           gcorr4_turn(1,i)))
10962         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
10963           gcorr4_turn_max=gcorr4_turn_norm
10964         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
10965         if (gradcorr5_norm.gt.gradcorr5_max) &
10966           gradcorr5_max=gradcorr5_norm
10967         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
10968         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
10969         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
10970           gcorr6_turn(1,i)))
10971         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
10972           gcorr6_turn_max=gcorr6_turn_norm
10973         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
10974         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
10975         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
10976         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
10977         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
10978         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
10979         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
10980         if (gradx_scp_norm.gt.gradx_scp_max) &
10981           gradx_scp_max=gradx_scp_norm
10982         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
10983         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
10984         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
10985         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
10986         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
10987         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
10988         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
10989         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
10990       enddo
10991       if (gradout) then
10992 #ifdef AIX
10993         open(istat,file=statname,position="append")
10994 #else
10995         open(istat,file=statname,access="append")
10996 #endif
10997         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
10998            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
10999            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11000            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11001            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11002            gsccorx_max,gsclocx_max
11003         close(istat)
11004         if (gvdwc_max.gt.1.0d4) then
11005           write (iout,*) "gvdwc gvdwx gradb gradbx"
11006           do i=nnt,nct
11007             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11008               gradb(j,i),gradbx(j,i),j=1,3)
11009           enddo
11010           call pdbout(0.0d0,'cipiszcze',iout)
11011           call flush(iout)
11012         endif
11013       endif
11014       endif
11015 !el#define DEBUG
11016 #ifdef DEBUG
11017       write (iout,*) "gradc gradx gloc"
11018       do i=1,nres
11019         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11020          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11021       enddo
11022 #endif
11023 !el#undef DEBUG
11024 #ifdef TIMING
11025       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11026 #endif
11027       return
11028       end subroutine sum_gradient
11029 !-----------------------------------------------------------------------------
11030       subroutine sc_grad
11031 !      implicit real*8 (a-h,o-z)
11032       use calc_data
11033 !      include 'DIMENSIONS'
11034 !      include 'COMMON.CHAIN'
11035 !      include 'COMMON.DERIV'
11036 !      include 'COMMON.CALC'
11037 !      include 'COMMON.IOUNITS'
11038       real(kind=8), dimension(3) :: dcosom1,dcosom2
11039 !      print *,"wchodze"
11040       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
11041       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
11042       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11043            -2.0D0*alf12*eps3der+sigder*sigsq_om12
11044 ! diagnostics only
11045 !      eom1=0.0d0
11046 !      eom2=0.0d0
11047 !      eom12=evdwij*eps1_om12
11048 ! end diagnostics
11049 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11050 !       " sigder",sigder
11051 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11052 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11053 !C      print *,sss_ele_cut,'in sc_grad'
11054       do k=1,3
11055         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11056         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11057       enddo
11058       do k=1,3
11059         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11060 !C      print *,'gg',k,gg(k)
11061        enddo
11062 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11063 !      write (iout,*) "gg",(gg(k),k=1,3)
11064       do k=1,3
11065         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11066                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11067                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11068                   *sss_ele_cut
11069
11070         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11071                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11072                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11073                   *sss_ele_cut
11074
11075 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11076 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11077 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11078 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11079       enddo
11080 !
11081 ! Calculate the components of the gradient in DC and X
11082 !
11083 !grad      do k=i,j-1
11084 !grad        do l=1,3
11085 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11086 !grad        enddo
11087 !grad      enddo
11088       do l=1,3
11089         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11090         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11091       enddo
11092       return
11093       end subroutine sc_grad
11094 #ifdef CRYST_THETA
11095 !-----------------------------------------------------------------------------
11096       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11097
11098       use comm_calcthet
11099 !      implicit real*8 (a-h,o-z)
11100 !      include 'DIMENSIONS'
11101 !      include 'COMMON.LOCAL'
11102 !      include 'COMMON.IOUNITS'
11103 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11104 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11105 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11106       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11107       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11108 !el      integer :: it
11109 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11110 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11111 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11112 !el local variables
11113
11114       delthec=thetai-thet_pred_mean
11115       delthe0=thetai-theta0i
11116 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11117       t3 = thetai-thet_pred_mean
11118       t6 = t3**2
11119       t9 = term1
11120       t12 = t3*sigcsq
11121       t14 = t12+t6*sigsqtc
11122       t16 = 1.0d0
11123       t21 = thetai-theta0i
11124       t23 = t21**2
11125       t26 = term2
11126       t27 = t21*t26
11127       t32 = termexp
11128       t40 = t32**2
11129       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11130        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11131        *(-t12*t9-ak*sig0inv*t27)
11132       return
11133       end subroutine mixder
11134 #endif
11135 !-----------------------------------------------------------------------------
11136 ! cartder.F
11137 !-----------------------------------------------------------------------------
11138       subroutine cartder
11139 !-----------------------------------------------------------------------------
11140 ! This subroutine calculates the derivatives of the consecutive virtual
11141 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11142 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11143 ! in the angles alpha and omega, describing the location of a side chain
11144 ! in its local coordinate system.
11145 !
11146 ! The derivatives are stored in the following arrays:
11147 !
11148 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11149 ! The structure is as follows:
11150 !
11151 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11152 ! 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)
11153 !         . . . . . . . . . . . .  . . . . . .
11154 ! 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)
11155 !                          .
11156 !                          .
11157 !                          .
11158 ! 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)
11159 !
11160 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11161 ! The structure is same as above.
11162 !
11163 ! DCDS - the derivatives of the side chain vectors in the local spherical
11164 ! andgles alph and omega:
11165 !
11166 ! 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)
11167 ! 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)
11168 !                          .
11169 !                          .
11170 !                          .
11171 ! 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)
11172 !
11173 ! Version of March '95, based on an early version of November '91.
11174 !
11175 !**********************************************************************
11176 !      implicit real*8 (a-h,o-z)
11177 !      include 'DIMENSIONS'
11178 !      include 'COMMON.VAR'
11179 !      include 'COMMON.CHAIN'
11180 !      include 'COMMON.DERIV'
11181 !      include 'COMMON.GEO'
11182 !      include 'COMMON.LOCAL'
11183 !      include 'COMMON.INTERACT'
11184       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11185       real(kind=8),dimension(3,3) :: dp,temp
11186 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11187       real(kind=8),dimension(3) :: xx,xx1
11188 !el local variables
11189       integer :: i,k,l,j,m,ind,ind1,jjj
11190       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11191                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11192                  sint2,xp,yp,xxp,yyp,zzp,dj
11193
11194 !      common /przechowalnia/ fromto
11195       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11196 ! get the position of the jth ijth fragment of the chain coordinate system
11197 ! in the fromto array.
11198 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11199 !
11200 !      maxdim=(nres-1)*(nres-2)/2
11201 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11202 ! calculate the derivatives of transformation matrix elements in theta
11203 !
11204
11205 !el      call flush(iout) !el
11206       do i=1,nres-2
11207         rdt(1,1,i)=-rt(1,2,i)
11208         rdt(1,2,i)= rt(1,1,i)
11209         rdt(1,3,i)= 0.0d0
11210         rdt(2,1,i)=-rt(2,2,i)
11211         rdt(2,2,i)= rt(2,1,i)
11212         rdt(2,3,i)= 0.0d0
11213         rdt(3,1,i)=-rt(3,2,i)
11214         rdt(3,2,i)= rt(3,1,i)
11215         rdt(3,3,i)= 0.0d0
11216       enddo
11217 !
11218 ! derivatives in phi
11219 !
11220       do i=2,nres-2
11221         drt(1,1,i)= 0.0d0
11222         drt(1,2,i)= 0.0d0
11223         drt(1,3,i)= 0.0d0
11224         drt(2,1,i)= rt(3,1,i)
11225         drt(2,2,i)= rt(3,2,i)
11226         drt(2,3,i)= rt(3,3,i)
11227         drt(3,1,i)=-rt(2,1,i)
11228         drt(3,2,i)=-rt(2,2,i)
11229         drt(3,3,i)=-rt(2,3,i)
11230       enddo
11231 !
11232 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11233 !
11234       do i=2,nres-2
11235         ind=indmat(i,i+1)
11236         do k=1,3
11237           do l=1,3
11238             temp(k,l)=rt(k,l,i)
11239           enddo
11240         enddo
11241         do k=1,3
11242           do l=1,3
11243             fromto(k,l,ind)=temp(k,l)
11244           enddo
11245         enddo
11246         do j=i+1,nres-2
11247           ind=indmat(i,j+1)
11248           do k=1,3
11249             do l=1,3
11250               dpkl=0.0d0
11251               do m=1,3
11252                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11253               enddo
11254               dp(k,l)=dpkl
11255               fromto(k,l,ind)=dpkl
11256             enddo
11257           enddo
11258           do k=1,3
11259             do l=1,3
11260               temp(k,l)=dp(k,l)
11261             enddo
11262           enddo
11263         enddo
11264       enddo
11265 !
11266 ! Calculate derivatives.
11267 !
11268       ind1=0
11269       do i=1,nres-2
11270       ind1=ind1+1
11271 !
11272 ! Derivatives of DC(i+1) in theta(i+2)
11273 !
11274         do j=1,3
11275           do k=1,2
11276             dpjk=0.0D0
11277             do l=1,3
11278               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11279             enddo
11280             dp(j,k)=dpjk
11281             prordt(j,k,i)=dp(j,k)
11282           enddo
11283           dp(j,3)=0.0D0
11284           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11285         enddo
11286 !
11287 ! Derivatives of SC(i+1) in theta(i+2)
11288 !
11289         xx1(1)=-0.5D0*xloc(2,i+1)
11290         xx1(2)= 0.5D0*xloc(1,i+1)
11291         do j=1,3
11292           xj=0.0D0
11293           do k=1,2
11294             xj=xj+r(j,k,i)*xx1(k)
11295           enddo
11296           xx(j)=xj
11297         enddo
11298         do j=1,3
11299           rj=0.0D0
11300           do k=1,3
11301             rj=rj+prod(j,k,i)*xx(k)
11302           enddo
11303           dxdv(j,ind1)=rj
11304         enddo
11305 !
11306 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11307 ! than the other off-diagonal derivatives.
11308 !
11309         do j=1,3
11310           dxoiij=0.0D0
11311           do k=1,3
11312             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11313           enddo
11314           dxdv(j,ind1+1)=dxoiij
11315         enddo
11316 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11317 !
11318 ! Derivatives of DC(i+1) in phi(i+2)
11319 !
11320         do j=1,3
11321           do k=1,3
11322             dpjk=0.0
11323             do l=2,3
11324               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11325             enddo
11326             dp(j,k)=dpjk
11327             prodrt(j,k,i)=dp(j,k)
11328           enddo
11329           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11330         enddo
11331 !
11332 ! Derivatives of SC(i+1) in phi(i+2)
11333 !
11334         xx(1)= 0.0D0
11335         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11336         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11337         do j=1,3
11338           rj=0.0D0
11339           do k=2,3
11340             rj=rj+prod(j,k,i)*xx(k)
11341           enddo
11342           dxdv(j+3,ind1)=-rj
11343         enddo
11344 !
11345 ! Derivatives of SC(i+1) in phi(i+3).
11346 !
11347         do j=1,3
11348           dxoiij=0.0D0
11349           do k=1,3
11350             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11351           enddo
11352           dxdv(j+3,ind1+1)=dxoiij
11353         enddo
11354 !
11355 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11356 ! theta(nres) and phi(i+3) thru phi(nres).
11357 !
11358         do j=i+1,nres-2
11359         ind1=ind1+1
11360         ind=indmat(i+1,j+1)
11361 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11362           do k=1,3
11363             do l=1,3
11364               tempkl=0.0D0
11365               do m=1,2
11366                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11367               enddo
11368               temp(k,l)=tempkl
11369             enddo
11370           enddo
11371 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11372 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11373 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11374 ! Derivatives of virtual-bond vectors in theta
11375           do k=1,3
11376             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11377           enddo
11378 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11379 ! Derivatives of SC vectors in theta
11380           do k=1,3
11381             dxoijk=0.0D0
11382             do l=1,3
11383               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11384             enddo
11385             dxdv(k,ind1+1)=dxoijk
11386           enddo
11387 !
11388 !--- Calculate the derivatives in phi
11389 !
11390           do k=1,3
11391             do l=1,3
11392               tempkl=0.0D0
11393               do m=1,3
11394                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11395               enddo
11396               temp(k,l)=tempkl
11397             enddo
11398           enddo
11399           do k=1,3
11400             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11401         enddo
11402           do k=1,3
11403             dxoijk=0.0D0
11404             do l=1,3
11405               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11406             enddo
11407             dxdv(k+3,ind1+1)=dxoijk
11408           enddo
11409         enddo
11410       enddo
11411 !
11412 ! Derivatives in alpha and omega:
11413 !
11414       do i=2,nres-1
11415 !       dsci=dsc(itype(i,1))
11416         dsci=vbld(i+nres)
11417 #ifdef OSF
11418         alphi=alph(i)
11419         omegi=omeg(i)
11420         if(alphi.ne.alphi) alphi=100.0
11421         if(omegi.ne.omegi) omegi=-100.0
11422 #else
11423       alphi=alph(i)
11424       omegi=omeg(i)
11425 #endif
11426 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11427       cosalphi=dcos(alphi)
11428       sinalphi=dsin(alphi)
11429       cosomegi=dcos(omegi)
11430       sinomegi=dsin(omegi)
11431       temp(1,1)=-dsci*sinalphi
11432       temp(2,1)= dsci*cosalphi*cosomegi
11433       temp(3,1)=-dsci*cosalphi*sinomegi
11434       temp(1,2)=0.0D0
11435       temp(2,2)=-dsci*sinalphi*sinomegi
11436       temp(3,2)=-dsci*sinalphi*cosomegi
11437       theta2=pi-0.5D0*theta(i+1)
11438       cost2=dcos(theta2)
11439       sint2=dsin(theta2)
11440       jjj=0
11441 !d      print *,((temp(l,k),l=1,3),k=1,2)
11442         do j=1,2
11443         xp=temp(1,j)
11444         yp=temp(2,j)
11445         xxp= xp*cost2+yp*sint2
11446         yyp=-xp*sint2+yp*cost2
11447         zzp=temp(3,j)
11448         xx(1)=xxp
11449         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11450         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11451         do k=1,3
11452           dj=0.0D0
11453           do l=1,3
11454             dj=dj+prod(k,l,i-1)*xx(l)
11455             enddo
11456           dxds(jjj+k,i)=dj
11457           enddo
11458         jjj=jjj+3
11459       enddo
11460       enddo
11461       return
11462       end subroutine cartder
11463 !-----------------------------------------------------------------------------
11464 ! checkder_p.F
11465 !-----------------------------------------------------------------------------
11466       subroutine check_cartgrad
11467 ! Check the gradient of Cartesian coordinates in internal coordinates.
11468 !      implicit real*8 (a-h,o-z)
11469 !      include 'DIMENSIONS'
11470 !      include 'COMMON.IOUNITS'
11471 !      include 'COMMON.VAR'
11472 !      include 'COMMON.CHAIN'
11473 !      include 'COMMON.GEO'
11474 !      include 'COMMON.LOCAL'
11475 !      include 'COMMON.DERIV'
11476       real(kind=8),dimension(6,nres) :: temp
11477       real(kind=8),dimension(3) :: xx,gg
11478       integer :: i,k,j,ii
11479       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11480 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11481 !
11482 ! Check the gradient of the virtual-bond and SC vectors in the internal
11483 ! coordinates.
11484 !
11485       aincr=1.0d-6
11486       aincr2=5.0d-7
11487       call cartder
11488       write (iout,'(a)') '**************** dx/dalpha'
11489       write (iout,'(a)')
11490       do i=2,nres-1
11491       alphi=alph(i)
11492       alph(i)=alph(i)+aincr
11493       do k=1,3
11494         temp(k,i)=dc(k,nres+i)
11495         enddo
11496       call chainbuild
11497       do k=1,3
11498         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11499         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11500         enddo
11501         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11502         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11503         write (iout,'(a)')
11504       alph(i)=alphi
11505       call chainbuild
11506       enddo
11507       write (iout,'(a)')
11508       write (iout,'(a)') '**************** dx/domega'
11509       write (iout,'(a)')
11510       do i=2,nres-1
11511       omegi=omeg(i)
11512       omeg(i)=omeg(i)+aincr
11513       do k=1,3
11514         temp(k,i)=dc(k,nres+i)
11515         enddo
11516       call chainbuild
11517       do k=1,3
11518           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11519           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11520                 (aincr*dabs(dxds(k+3,i))+aincr))
11521         enddo
11522         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11523             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11524         write (iout,'(a)')
11525       omeg(i)=omegi
11526       call chainbuild
11527       enddo
11528       write (iout,'(a)')
11529       write (iout,'(a)') '**************** dx/dtheta'
11530       write (iout,'(a)')
11531       do i=3,nres
11532       theti=theta(i)
11533         theta(i)=theta(i)+aincr
11534         do j=i-1,nres-1
11535           do k=1,3
11536             temp(k,j)=dc(k,nres+j)
11537           enddo
11538         enddo
11539         call chainbuild
11540         do j=i-1,nres-1
11541         ii = indmat(i-2,j)
11542 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11543         do k=1,3
11544           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11545           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11546                   (aincr*dabs(dxdv(k,ii))+aincr))
11547           enddo
11548           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11549               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11550           write(iout,'(a)')
11551         enddo
11552         write (iout,'(a)')
11553         theta(i)=theti
11554         call chainbuild
11555       enddo
11556       write (iout,'(a)') '***************** dx/dphi'
11557       write (iout,'(a)')
11558       do i=4,nres
11559         phi(i)=phi(i)+aincr
11560         do j=i-1,nres-1
11561           do k=1,3
11562             temp(k,j)=dc(k,nres+j)
11563           enddo
11564         enddo
11565         call chainbuild
11566         do j=i-1,nres-1
11567         ii = indmat(i-2,j)
11568 !         print *,'ii=',ii
11569         do k=1,3
11570           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11571             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11572                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11573           enddo
11574           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11575               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11576           write(iout,'(a)')
11577         enddo
11578         phi(i)=phi(i)-aincr
11579         call chainbuild
11580       enddo
11581       write (iout,'(a)') '****************** ddc/dtheta'
11582       do i=1,nres-2
11583         thet=theta(i+2)
11584         theta(i+2)=thet+aincr
11585         do j=i,nres
11586           do k=1,3
11587             temp(k,j)=dc(k,j)
11588           enddo
11589         enddo
11590         call chainbuild
11591         do j=i+1,nres-1
11592         ii = indmat(i,j)
11593 !         print *,'ii=',ii
11594         do k=1,3
11595           gg(k)=(dc(k,j)-temp(k,j))/aincr
11596           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11597                  (aincr*dabs(dcdv(k,ii))+aincr))
11598           enddo
11599           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11600                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11601         write (iout,'(a)')
11602         enddo
11603         do j=1,nres
11604           do k=1,3
11605             dc(k,j)=temp(k,j)
11606           enddo
11607         enddo
11608         theta(i+2)=thet
11609       enddo
11610       write (iout,'(a)') '******************* ddc/dphi'
11611       do i=1,nres-3
11612         phii=phi(i+3)
11613         phi(i+3)=phii+aincr
11614         do j=1,nres
11615           do k=1,3
11616             temp(k,j)=dc(k,j)
11617           enddo
11618         enddo
11619         call chainbuild
11620         do j=i+2,nres-1
11621         ii = indmat(i+1,j)
11622 !         print *,'ii=',ii
11623         do k=1,3
11624           gg(k)=(dc(k,j)-temp(k,j))/aincr
11625             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11626                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11627           enddo
11628           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11629                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11630         write (iout,'(a)')
11631         enddo
11632         do j=1,nres
11633           do k=1,3
11634             dc(k,j)=temp(k,j)
11635           enddo
11636         enddo
11637         phi(i+3)=phii
11638       enddo
11639       return
11640       end subroutine check_cartgrad
11641 !-----------------------------------------------------------------------------
11642       subroutine check_ecart
11643 ! Check the gradient of the energy in Cartesian coordinates.
11644 !     implicit real*8 (a-h,o-z)
11645 !     include 'DIMENSIONS'
11646 !     include 'COMMON.CHAIN'
11647 !     include 'COMMON.DERIV'
11648 !     include 'COMMON.IOUNITS'
11649 !     include 'COMMON.VAR'
11650 !     include 'COMMON.CONTACTS'
11651       use comm_srutu
11652 !el      integer :: icall
11653 !el      common /srutu/ icall
11654       real(kind=8),dimension(6) :: ggg
11655       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11656       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11657       real(kind=8),dimension(6,nres) :: grad_s
11658       real(kind=8),dimension(0:n_ene) :: energia,energia1
11659       integer :: uiparm(1)
11660       real(kind=8) :: urparm(1)
11661 !EL      external fdum
11662       integer :: nf,i,j,k
11663       real(kind=8) :: aincr,etot,etot1
11664       icg=1
11665       nf=0
11666       nfl=0
11667       call zerograd
11668       aincr=1.0D-5
11669       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11670       nf=0
11671       icall=0
11672       call geom_to_var(nvar,x)
11673       call etotal(energia)
11674       etot=energia(0)
11675 !el      call enerprint(energia)
11676       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11677       icall =1
11678       do i=1,nres
11679         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11680       enddo
11681       do i=1,nres
11682       do j=1,3
11683         grad_s(j,i)=gradc(j,i,icg)
11684         grad_s(j+3,i)=gradx(j,i,icg)
11685         enddo
11686       enddo
11687       call flush(iout)
11688       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11689       do i=1,nres
11690         do j=1,3
11691         xx(j)=c(j,i+nres)
11692         ddc(j)=dc(j,i)
11693         ddx(j)=dc(j,i+nres)
11694         enddo
11695       do j=1,3
11696         dc(j,i)=dc(j,i)+aincr
11697         do k=i+1,nres
11698           c(j,k)=c(j,k)+aincr
11699           c(j,k+nres)=c(j,k+nres)+aincr
11700           enddo
11701           call etotal(energia1)
11702           etot1=energia1(0)
11703         ggg(j)=(etot1-etot)/aincr
11704         dc(j,i)=ddc(j)
11705         do k=i+1,nres
11706           c(j,k)=c(j,k)-aincr
11707           c(j,k+nres)=c(j,k+nres)-aincr
11708           enddo
11709         enddo
11710       do j=1,3
11711         c(j,i+nres)=c(j,i+nres)+aincr
11712         dc(j,i+nres)=dc(j,i+nres)+aincr
11713           call etotal(energia1)
11714           etot1=energia1(0)
11715         ggg(j+3)=(etot1-etot)/aincr
11716         c(j,i+nres)=xx(j)
11717         dc(j,i+nres)=ddx(j)
11718         enddo
11719       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11720          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11721       enddo
11722       return
11723       end subroutine check_ecart
11724 #ifdef CARGRAD
11725 !-----------------------------------------------------------------------------
11726       subroutine check_ecartint
11727 ! Check the gradient of the energy in Cartesian coordinates.
11728       use io_base, only: intout
11729 !      implicit real*8 (a-h,o-z)
11730 !      include 'DIMENSIONS'
11731 !      include 'COMMON.CONTROL'
11732 !      include 'COMMON.CHAIN'
11733 !      include 'COMMON.DERIV'
11734 !      include 'COMMON.IOUNITS'
11735 !      include 'COMMON.VAR'
11736 !      include 'COMMON.CONTACTS'
11737 !      include 'COMMON.MD'
11738 !      include 'COMMON.LOCAL'
11739 !      include 'COMMON.SPLITELE'
11740       use comm_srutu
11741 !el      integer :: icall
11742 !el      common /srutu/ icall
11743       real(kind=8),dimension(6) :: ggg,ggg1
11744       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11745       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11746       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11747       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11748       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11749       real(kind=8),dimension(0:n_ene) :: energia,energia1
11750       integer :: uiparm(1)
11751       real(kind=8) :: urparm(1)
11752 !EL      external fdum
11753       integer :: i,j,k,nf
11754       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11755                    etot21,etot22
11756       r_cut=2.0d0
11757       rlambd=0.3d0
11758       icg=1
11759       nf=0
11760       nfl=0
11761       call intout
11762 !      call intcartderiv
11763 !      call checkintcartgrad
11764       call zerograd
11765       aincr=1.0D-5
11766       write(iout,*) 'Calling CHECK_ECARTINT.'
11767       nf=0
11768       icall=0
11769       write (iout,*) "Before geom_to_var"
11770       call geom_to_var(nvar,x)
11771       write (iout,*) "after geom_to_var"
11772       write (iout,*) "split_ene ",split_ene
11773       call flush(iout)
11774       if (.not.split_ene) then
11775         write(iout,*) 'Calling CHECK_ECARTINT if'
11776         call etotal(energia)
11777 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11778         etot=energia(0)
11779         write (iout,*) "etot",etot
11780         call flush(iout)
11781 !el        call enerprint(energia)
11782 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11783         call flush(iout)
11784         write (iout,*) "enter cartgrad"
11785         call flush(iout)
11786         call cartgrad
11787 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11788         write (iout,*) "exit cartgrad"
11789         call flush(iout)
11790         icall =1
11791         do i=1,nres
11792           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11793         enddo
11794         do j=1,3
11795           grad_s(j,0)=gcart(j,0)
11796         enddo
11797 !elwrite(iout,*) 'Calling CHECK_ECARTINT if'
11798         do i=1,nres
11799           do j=1,3
11800             grad_s(j,i)=gcart(j,i)
11801             grad_s(j+3,i)=gxcart(j,i)
11802           enddo
11803         enddo
11804       else
11805 write(iout,*) 'Calling CHECK_ECARTIN else.'
11806 !- split gradient check
11807         call zerograd
11808         call etotal_long(energia)
11809 !el        call enerprint(energia)
11810         call flush(iout)
11811         write (iout,*) "enter cartgrad"
11812         call flush(iout)
11813         call cartgrad
11814         write (iout,*) "exit cartgrad"
11815         call flush(iout)
11816         icall =1
11817         write (iout,*) "longrange grad"
11818         do i=1,nres
11819           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11820           (gxcart(j,i),j=1,3)
11821         enddo
11822         do j=1,3
11823           grad_s(j,0)=gcart(j,0)
11824         enddo
11825         do i=1,nres
11826           do j=1,3
11827             grad_s(j,i)=gcart(j,i)
11828             grad_s(j+3,i)=gxcart(j,i)
11829           enddo
11830         enddo
11831         call zerograd
11832         call etotal_short(energia)
11833         call enerprint(energia)
11834         call flush(iout)
11835         write (iout,*) "enter cartgrad"
11836         call flush(iout)
11837         call cartgrad
11838         write (iout,*) "exit cartgrad"
11839         call flush(iout)
11840         icall =1
11841         write (iout,*) "shortrange grad"
11842         do i=1,nres
11843           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11844           (gxcart(j,i),j=1,3)
11845         enddo
11846         do j=1,3
11847           grad_s1(j,0)=gcart(j,0)
11848         enddo
11849         do i=1,nres
11850           do j=1,3
11851             grad_s1(j,i)=gcart(j,i)
11852             grad_s1(j+3,i)=gxcart(j,i)
11853           enddo
11854         enddo
11855       endif
11856       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11857 !      do i=1,nres
11858       do i=nnt,nct
11859         do j=1,3
11860           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11861           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11862         ddc(j)=c(j,i)
11863         ddx(j)=c(j,i+nres)
11864           dcnorm_safe1(j)=dc_norm(j,i-1)
11865           dcnorm_safe2(j)=dc_norm(j,i)
11866           dxnorm_safe(j)=dc_norm(j,i+nres)
11867         enddo
11868       do j=1,3
11869         c(j,i)=ddc(j)+aincr
11870           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11871           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11872           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11873           dc(j,i)=c(j,i+1)-c(j,i)
11874           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11875           call int_from_cart1(.false.)
11876           if (.not.split_ene) then
11877             call etotal(energia1)
11878             etot1=energia1(0)
11879             write (iout,*) "ij",i,j," etot1",etot1
11880           else
11881 !- split gradient
11882             call etotal_long(energia1)
11883             etot11=energia1(0)
11884             call etotal_short(energia1)
11885             etot12=energia1(0)
11886           endif
11887 !- end split gradient
11888 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11889         c(j,i)=ddc(j)-aincr
11890           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11891           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11892           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11893           dc(j,i)=c(j,i+1)-c(j,i)
11894           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11895           call int_from_cart1(.false.)
11896           if (.not.split_ene) then
11897             call etotal(energia1)
11898             etot2=energia1(0)
11899             write (iout,*) "ij",i,j," etot2",etot2
11900           ggg(j)=(etot1-etot2)/(2*aincr)
11901           else
11902 !- split gradient
11903             call etotal_long(energia1)
11904             etot21=energia1(0)
11905           ggg(j)=(etot11-etot21)/(2*aincr)
11906             call etotal_short(energia1)
11907             etot22=energia1(0)
11908           ggg1(j)=(etot12-etot22)/(2*aincr)
11909 !- end split gradient
11910 !            write (iout,*) "etot21",etot21," etot22",etot22
11911           endif
11912 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11913         c(j,i)=ddc(j)
11914           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11915           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11916           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11917           dc(j,i)=c(j,i+1)-c(j,i)
11918           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11919           dc_norm(j,i-1)=dcnorm_safe1(j)
11920           dc_norm(j,i)=dcnorm_safe2(j)
11921           dc_norm(j,i+nres)=dxnorm_safe(j)
11922         enddo
11923       do j=1,3
11924         c(j,i+nres)=ddx(j)+aincr
11925           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11926           call int_from_cart1(.false.)
11927           if (.not.split_ene) then
11928             call etotal(energia1)
11929             etot1=energia1(0)
11930           else
11931 !- split gradient
11932             call etotal_long(energia1)
11933             etot11=energia1(0)
11934             call etotal_short(energia1)
11935             etot12=energia1(0)
11936           endif
11937 !- end split gradient
11938         c(j,i+nres)=ddx(j)-aincr
11939           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11940           call int_from_cart1(.false.)
11941           if (.not.split_ene) then
11942             call etotal(energia1)
11943             etot2=energia1(0)
11944           ggg(j+3)=(etot1-etot2)/(2*aincr)
11945           else
11946 !- split gradient
11947             call etotal_long(energia1)
11948             etot21=energia1(0)
11949           ggg(j+3)=(etot11-etot21)/(2*aincr)
11950             call etotal_short(energia1)
11951             etot22=energia1(0)
11952           ggg1(j+3)=(etot12-etot22)/(2*aincr)
11953 !- end split gradient
11954           endif
11955 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11956         c(j,i+nres)=ddx(j)
11957           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11958           dc_norm(j,i+nres)=dxnorm_safe(j)
11959           call int_from_cart1(.false.)
11960         enddo
11961       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11962          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
11963         if (split_ene) then
11964           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11965          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
11966          k=1,6)
11967          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
11968          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
11969          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
11970         endif
11971       enddo
11972       return
11973       end subroutine check_ecartint
11974 #else
11975 !-----------------------------------------------------------------------------
11976       subroutine check_ecartint
11977 ! Check the gradient of the energy in Cartesian coordinates.
11978       use io_base, only: intout
11979 !      implicit real*8 (a-h,o-z)
11980 !      include 'DIMENSIONS'
11981 !      include 'COMMON.CONTROL'
11982 !      include 'COMMON.CHAIN'
11983 !      include 'COMMON.DERIV'
11984 !      include 'COMMON.IOUNITS'
11985 !      include 'COMMON.VAR'
11986 !      include 'COMMON.CONTACTS'
11987 !      include 'COMMON.MD'
11988 !      include 'COMMON.LOCAL'
11989 !      include 'COMMON.SPLITELE'
11990       use comm_srutu
11991 !el      integer :: icall
11992 !el      common /srutu/ icall
11993       real(kind=8),dimension(6) :: ggg,ggg1
11994       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11995       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11996       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
11997       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11998       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11999       real(kind=8),dimension(0:n_ene) :: energia,energia1
12000       integer :: uiparm(1)
12001       real(kind=8) :: urparm(1)
12002 !EL      external fdum
12003       integer :: i,j,k,nf
12004       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12005                    etot21,etot22
12006       r_cut=2.0d0
12007       rlambd=0.3d0
12008       icg=1
12009       nf=0
12010       nfl=0
12011       call intout
12012 !      call intcartderiv
12013 !      call checkintcartgrad
12014       call zerograd
12015       aincr=2.0D-5
12016       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12017       nf=0
12018       icall=0
12019       call geom_to_var(nvar,x)
12020       if (.not.split_ene) then
12021         call etotal(energia)
12022         etot=energia(0)
12023 !el        call enerprint(energia)
12024         call flush(iout)
12025         write (iout,*) "enter cartgrad"
12026         call flush(iout)
12027         call cartgrad
12028         write (iout,*) "exit cartgrad"
12029         call flush(iout)
12030         icall =1
12031         do i=1,nres
12032           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12033         enddo
12034         do j=1,3
12035           grad_s(j,0)=gcart(j,0)
12036         enddo
12037         do i=1,nres
12038           do j=1,3
12039             grad_s(j,i)=gcart(j,i)
12040 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12041             grad_s(j+3,i)=gxcart(j,i)
12042           enddo
12043         enddo
12044       else
12045 !- split gradient check
12046         call zerograd
12047         call etotal_long(energia)
12048 !el        call enerprint(energia)
12049         call flush(iout)
12050         write (iout,*) "enter cartgrad"
12051         call flush(iout)
12052         call cartgrad
12053         write (iout,*) "exit cartgrad"
12054         call flush(iout)
12055         icall =1
12056         write (iout,*) "longrange grad"
12057         do i=1,nres
12058           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12059           (gxcart(j,i),j=1,3)
12060         enddo
12061         do j=1,3
12062           grad_s(j,0)=gcart(j,0)
12063         enddo
12064         do i=1,nres
12065           do j=1,3
12066             grad_s(j,i)=gcart(j,i)
12067             grad_s(j+3,i)=gxcart(j,i)
12068           enddo
12069         enddo
12070         call zerograd
12071         call etotal_short(energia)
12072 !el        call enerprint(energia)
12073         call flush(iout)
12074         write (iout,*) "enter cartgrad"
12075         call flush(iout)
12076         call cartgrad
12077         write (iout,*) "exit cartgrad"
12078         call flush(iout)
12079         icall =1
12080         write (iout,*) "shortrange grad"
12081         do i=1,nres
12082           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12083           (gxcart(j,i),j=1,3)
12084         enddo
12085         do j=1,3
12086           grad_s1(j,0)=gcart(j,0)
12087         enddo
12088         do i=1,nres
12089           do j=1,3
12090             grad_s1(j,i)=gcart(j,i)
12091             grad_s1(j+3,i)=gxcart(j,i)
12092           enddo
12093         enddo
12094       endif
12095       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12096       do i=0,nres
12097         do j=1,3
12098         xx(j)=c(j,i+nres)
12099         ddc(j)=dc(j,i)
12100         ddx(j)=dc(j,i+nres)
12101           do k=1,3
12102             dcnorm_safe(k)=dc_norm(k,i)
12103             dxnorm_safe(k)=dc_norm(k,i+nres)
12104           enddo
12105         enddo
12106       do j=1,3
12107         dc(j,i)=ddc(j)+aincr
12108           call chainbuild_cart
12109 #ifdef MPI
12110 ! Broadcast the order to compute internal coordinates to the slaves.
12111 !          if (nfgtasks.gt.1)
12112 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12113 #endif
12114 !          call int_from_cart1(.false.)
12115           if (.not.split_ene) then
12116             call etotal(energia1)
12117             etot1=energia1(0)
12118 !            call enerprint(energia1)
12119           else
12120 !- split gradient
12121             call etotal_long(energia1)
12122             etot11=energia1(0)
12123             call etotal_short(energia1)
12124             etot12=energia1(0)
12125 !            write (iout,*) "etot11",etot11," etot12",etot12
12126           endif
12127 !- end split gradient
12128 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12129         dc(j,i)=ddc(j)-aincr
12130           call chainbuild_cart
12131 !          call int_from_cart1(.false.)
12132           if (.not.split_ene) then
12133             call etotal(energia1)
12134             etot2=energia1(0)
12135           ggg(j)=(etot1-etot2)/(2*aincr)
12136           else
12137 !- split gradient
12138             call etotal_long(energia1)
12139             etot21=energia1(0)
12140           ggg(j)=(etot11-etot21)/(2*aincr)
12141             call etotal_short(energia1)
12142             etot22=energia1(0)
12143           ggg1(j)=(etot12-etot22)/(2*aincr)
12144 !- end split gradient
12145 !            write (iout,*) "etot21",etot21," etot22",etot22
12146           endif
12147 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12148         dc(j,i)=ddc(j)
12149           call chainbuild_cart
12150         enddo
12151       do j=1,3
12152         dc(j,i+nres)=ddx(j)+aincr
12153           call chainbuild_cart
12154 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12155 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12156 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12157 !          write (iout,*) "dxnormnorm",dsqrt(
12158 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12159 !          write (iout,*) "dxnormnormsafe",dsqrt(
12160 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12161 !          write (iout,*)
12162           if (.not.split_ene) then
12163             call etotal(energia1)
12164             etot1=energia1(0)
12165           else
12166 !- split gradient
12167             call etotal_long(energia1)
12168             etot11=energia1(0)
12169             call etotal_short(energia1)
12170             etot12=energia1(0)
12171           endif
12172 !- end split gradient
12173 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12174         dc(j,i+nres)=ddx(j)-aincr
12175           call chainbuild_cart
12176 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12177 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12178 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12179 !          write (iout,*)
12180 !          write (iout,*) "dxnormnorm",dsqrt(
12181 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12182 !          write (iout,*) "dxnormnormsafe",dsqrt(
12183 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12184           if (.not.split_ene) then
12185             call etotal(energia1)
12186             etot2=energia1(0)
12187           ggg(j+3)=(etot1-etot2)/(2*aincr)
12188           else
12189 !- split gradient
12190             call etotal_long(energia1)
12191             etot21=energia1(0)
12192           ggg(j+3)=(etot11-etot21)/(2*aincr)
12193             call etotal_short(energia1)
12194             etot22=energia1(0)
12195           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12196 !- end split gradient
12197           endif
12198 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12199         dc(j,i+nres)=ddx(j)
12200           call chainbuild_cart
12201         enddo
12202       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12203          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12204         if (split_ene) then
12205           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12206          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12207          k=1,6)
12208          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12209          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12210          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12211         endif
12212       enddo
12213       return
12214       end subroutine check_ecartint
12215 #endif
12216 !-----------------------------------------------------------------------------
12217       subroutine check_eint
12218 ! Check the gradient of energy in internal coordinates.
12219 !      implicit real*8 (a-h,o-z)
12220 !      include 'DIMENSIONS'
12221 !      include 'COMMON.CHAIN'
12222 !      include 'COMMON.DERIV'
12223 !      include 'COMMON.IOUNITS'
12224 !      include 'COMMON.VAR'
12225 !      include 'COMMON.GEO'
12226       use comm_srutu
12227 !el      integer :: icall
12228 !el      common /srutu/ icall
12229       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12230       integer :: uiparm(1)
12231       real(kind=8) :: urparm(1)
12232       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12233       character(len=6) :: key
12234 !EL      external fdum
12235       integer :: i,ii,nf
12236       real(kind=8) :: xi,aincr,etot,etot1,etot2
12237       call zerograd
12238       aincr=1.0D-7
12239       print '(a)','Calling CHECK_INT.'
12240       nf=0
12241       nfl=0
12242       icg=1
12243       call geom_to_var(nvar,x)
12244       call var_to_geom(nvar,x)
12245       call chainbuild
12246       icall=1
12247 !      print *,'ICG=',ICG
12248       call etotal(energia)
12249       etot = energia(0)
12250 !el      call enerprint(energia)
12251 !      print *,'ICG=',ICG
12252 #ifdef MPL
12253       if (MyID.ne.BossID) then
12254         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12255         nf=x(nvar+1)
12256         nfl=x(nvar+2)
12257         icg=x(nvar+3)
12258       endif
12259 #endif
12260       nf=1
12261       nfl=3
12262 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12263       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12264 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12265       icall=1
12266       do i=1,nvar
12267         xi=x(i)
12268         x(i)=xi-0.5D0*aincr
12269         call var_to_geom(nvar,x)
12270         call chainbuild
12271         call etotal(energia1)
12272         etot1=energia1(0)
12273         x(i)=xi+0.5D0*aincr
12274         call var_to_geom(nvar,x)
12275         call chainbuild
12276         call etotal(energia2)
12277         etot2=energia2(0)
12278         gg(i)=(etot2-etot1)/aincr
12279         write (iout,*) i,etot1,etot2
12280         x(i)=xi
12281       enddo
12282       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12283           '     RelDiff*100% '
12284       do i=1,nvar
12285         if (i.le.nphi) then
12286           ii=i
12287           key = ' phi'
12288         else if (i.le.nphi+ntheta) then
12289           ii=i-nphi
12290           key=' theta'
12291         else if (i.le.nphi+ntheta+nside) then
12292            ii=i-(nphi+ntheta)
12293            key=' alpha'
12294         else
12295            ii=i-(nphi+ntheta+nside)
12296            key=' omega'
12297         endif
12298         write (iout,'(i3,a,i3,3(1pd16.6))') &
12299        i,key,ii,gg(i),gana(i),&
12300        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12301       enddo
12302       return
12303       end subroutine check_eint
12304 !-----------------------------------------------------------------------------
12305 ! econstr_local.F
12306 !-----------------------------------------------------------------------------
12307       subroutine Econstr_back
12308 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12309 !      implicit real*8 (a-h,o-z)
12310 !      include 'DIMENSIONS'
12311 !      include 'COMMON.CONTROL'
12312 !      include 'COMMON.VAR'
12313 !      include 'COMMON.MD'
12314       use MD_data
12315 !#ifndef LANG0
12316 !      include 'COMMON.LANGEVIN'
12317 !#else
12318 !      include 'COMMON.LANGEVIN.lang0'
12319 !#endif
12320 !      include 'COMMON.CHAIN'
12321 !      include 'COMMON.DERIV'
12322 !      include 'COMMON.GEO'
12323 !      include 'COMMON.LOCAL'
12324 !      include 'COMMON.INTERACT'
12325 !      include 'COMMON.IOUNITS'
12326 !      include 'COMMON.NAMES'
12327 !      include 'COMMON.TIME1'
12328       integer :: i,j,ii,k
12329       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12330
12331       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12332       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12333       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12334
12335       Uconst_back=0.0d0
12336       do i=1,nres
12337         dutheta(i)=0.0d0
12338         dugamma(i)=0.0d0
12339         do j=1,3
12340           duscdiff(j,i)=0.0d0
12341           duscdiffx(j,i)=0.0d0
12342         enddo
12343       enddo
12344       do i=1,nfrag_back
12345         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12346 !
12347 ! Deviations from theta angles
12348 !
12349         utheta_i=0.0d0
12350         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12351           dtheta_i=theta(j)-thetaref(j)
12352           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12353           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12354         enddo
12355         utheta(i)=utheta_i/(ii-1)
12356 !
12357 ! Deviations from gamma angles
12358 !
12359         ugamma_i=0.0d0
12360         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12361           dgamma_i=pinorm(phi(j)-phiref(j))
12362 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12363           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12364           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12365 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12366         enddo
12367         ugamma(i)=ugamma_i/(ii-2)
12368 !
12369 ! Deviations from local SC geometry
12370 !
12371         uscdiff(i)=0.0d0
12372         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12373           dxx=xxtab(j)-xxref(j)
12374           dyy=yytab(j)-yyref(j)
12375           dzz=zztab(j)-zzref(j)
12376           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12377           do k=1,3
12378             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12379              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12380              (ii-1)
12381             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12382              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12383              (ii-1)
12384             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12385            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12386             /(ii-1)
12387           enddo
12388 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12389 !     &      xxref(j),yyref(j),zzref(j)
12390         enddo
12391         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12392 !        write (iout,*) i," uscdiff",uscdiff(i)
12393 !
12394 ! Put together deviations from local geometry
12395 !
12396         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12397           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12398 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12399 !     &   " uconst_back",uconst_back
12400         utheta(i)=dsqrt(utheta(i))
12401         ugamma(i)=dsqrt(ugamma(i))
12402         uscdiff(i)=dsqrt(uscdiff(i))
12403       enddo
12404       return
12405       end subroutine Econstr_back
12406 !-----------------------------------------------------------------------------
12407 ! energy_p_new-sep_barrier.F
12408 !-----------------------------------------------------------------------------
12409       real(kind=8) function sscale(r)
12410 !      include "COMMON.SPLITELE"
12411       real(kind=8) :: r,gamm
12412       if(r.lt.r_cut-rlamb) then
12413         sscale=1.0d0
12414       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12415         gamm=(r-(r_cut-rlamb))/rlamb
12416         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12417       else
12418         sscale=0d0
12419       endif
12420       return
12421       end function sscale
12422       real(kind=8) function sscale_grad(r)
12423 !      include "COMMON.SPLITELE"
12424       real(kind=8) :: r,gamm
12425       if(r.lt.r_cut-rlamb) then
12426         sscale_grad=0.0d0
12427       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12428         gamm=(r-(r_cut-rlamb))/rlamb
12429         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12430       else
12431         sscale_grad=0d0
12432       endif
12433       return
12434       end function sscale_grad
12435
12436 !!!!!!!!!! PBCSCALE
12437       real(kind=8) function sscale_ele(r)
12438 !      include "COMMON.SPLITELE"
12439       real(kind=8) :: r,gamm
12440       if(r.lt.r_cut_ele-rlamb_ele) then
12441         sscale_ele=1.0d0
12442       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12443         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12444         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12445       else
12446         sscale_ele=0d0
12447       endif
12448       return
12449       end function sscale_ele
12450
12451       real(kind=8)  function sscagrad_ele(r)
12452       real(kind=8) :: r,gamm
12453 !      include "COMMON.SPLITELE"
12454       if(r.lt.r_cut_ele-rlamb_ele) then
12455         sscagrad_ele=0.0d0
12456       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12457         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12458         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12459       else
12460         sscagrad_ele=0.0d0
12461       endif
12462       return
12463       end function sscagrad_ele
12464       real(kind=8) function sscalelip(r)
12465       real(kind=8) r,gamm
12466         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12467       return
12468       end function sscalelip
12469 !C-----------------------------------------------------------------------
12470       real(kind=8) function sscagradlip(r)
12471       real(kind=8) r,gamm
12472         sscagradlip=r*(6.0d0*r-6.0d0)
12473       return
12474       end function sscagradlip
12475
12476 !!!!!!!!!!!!!!!
12477 !-----------------------------------------------------------------------------
12478       subroutine elj_long(evdw)
12479 !
12480 ! This subroutine calculates the interaction energy of nonbonded side chains
12481 ! assuming the LJ potential of interaction.
12482 !
12483 !      implicit real*8 (a-h,o-z)
12484 !      include 'DIMENSIONS'
12485 !      include 'COMMON.GEO'
12486 !      include 'COMMON.VAR'
12487 !      include 'COMMON.LOCAL'
12488 !      include 'COMMON.CHAIN'
12489 !      include 'COMMON.DERIV'
12490 !      include 'COMMON.INTERACT'
12491 !      include 'COMMON.TORSION'
12492 !      include 'COMMON.SBRIDGE'
12493 !      include 'COMMON.NAMES'
12494 !      include 'COMMON.IOUNITS'
12495 !      include 'COMMON.CONTACTS'
12496       real(kind=8),parameter :: accur=1.0d-10
12497       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12498 !el local variables
12499       integer :: i,iint,j,k,itypi,itypi1,itypj
12500       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12501       real(kind=8) :: e1,e2,evdwij,evdw
12502 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12503       evdw=0.0D0
12504       do i=iatsc_s,iatsc_e
12505         itypi=itype(i,1)
12506         if (itypi.eq.ntyp1) cycle
12507         itypi1=itype(i+1,1)
12508         xi=c(1,nres+i)
12509         yi=c(2,nres+i)
12510         zi=c(3,nres+i)
12511 !
12512 ! Calculate SC interaction energy.
12513 !
12514         do iint=1,nint_gr(i)
12515 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12516 !d   &                  'iend=',iend(i,iint)
12517           do j=istart(i,iint),iend(i,iint)
12518             itypj=itype(j,1)
12519             if (itypj.eq.ntyp1) cycle
12520             xj=c(1,nres+j)-xi
12521             yj=c(2,nres+j)-yi
12522             zj=c(3,nres+j)-zi
12523             rij=xj*xj+yj*yj+zj*zj
12524             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12525             if (sss.lt.1.0d0) then
12526               rrij=1.0D0/rij
12527               eps0ij=eps(itypi,itypj)
12528               fac=rrij**expon2
12529               e1=fac*fac*aa_aq(itypi,itypj)
12530               e2=fac*bb_aq(itypi,itypj)
12531               evdwij=e1+e2
12532               evdw=evdw+(1.0d0-sss)*evdwij
12533 !
12534 ! Calculate the components of the gradient in DC and X
12535 !
12536               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12537               gg(1)=xj*fac
12538               gg(2)=yj*fac
12539               gg(3)=zj*fac
12540               do k=1,3
12541                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12542                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12543                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12544                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12545               enddo
12546             endif
12547           enddo      ! j
12548         enddo        ! iint
12549       enddo          ! i
12550       do i=1,nct
12551         do j=1,3
12552           gvdwc(j,i)=expon*gvdwc(j,i)
12553           gvdwx(j,i)=expon*gvdwx(j,i)
12554         enddo
12555       enddo
12556 !******************************************************************************
12557 !
12558 !                              N O T E !!!
12559 !
12560 ! To save time, the factor of EXPON has been extracted from ALL components
12561 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12562 ! use!
12563 !
12564 !******************************************************************************
12565       return
12566       end subroutine elj_long
12567 !-----------------------------------------------------------------------------
12568       subroutine elj_short(evdw)
12569 !
12570 ! This subroutine calculates the interaction energy of nonbonded side chains
12571 ! assuming the LJ potential of interaction.
12572 !
12573 !      implicit real*8 (a-h,o-z)
12574 !      include 'DIMENSIONS'
12575 !      include 'COMMON.GEO'
12576 !      include 'COMMON.VAR'
12577 !      include 'COMMON.LOCAL'
12578 !      include 'COMMON.CHAIN'
12579 !      include 'COMMON.DERIV'
12580 !      include 'COMMON.INTERACT'
12581 !      include 'COMMON.TORSION'
12582 !      include 'COMMON.SBRIDGE'
12583 !      include 'COMMON.NAMES'
12584 !      include 'COMMON.IOUNITS'
12585 !      include 'COMMON.CONTACTS'
12586       real(kind=8),parameter :: accur=1.0d-10
12587       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12588 !el local variables
12589       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12590       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12591       real(kind=8) :: e1,e2,evdwij,evdw
12592 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12593       evdw=0.0D0
12594       do i=iatsc_s,iatsc_e
12595         itypi=itype(i,1)
12596         if (itypi.eq.ntyp1) cycle
12597         itypi1=itype(i+1,1)
12598         xi=c(1,nres+i)
12599         yi=c(2,nres+i)
12600         zi=c(3,nres+i)
12601 ! Change 12/1/95
12602         num_conti=0
12603 !
12604 ! Calculate SC interaction energy.
12605 !
12606         do iint=1,nint_gr(i)
12607 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12608 !d   &                  'iend=',iend(i,iint)
12609           do j=istart(i,iint),iend(i,iint)
12610             itypj=itype(j,1)
12611             if (itypj.eq.ntyp1) cycle
12612             xj=c(1,nres+j)-xi
12613             yj=c(2,nres+j)-yi
12614             zj=c(3,nres+j)-zi
12615 ! Change 12/1/95 to calculate four-body interactions
12616             rij=xj*xj+yj*yj+zj*zj
12617             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12618             if (sss.gt.0.0d0) then
12619               rrij=1.0D0/rij
12620               eps0ij=eps(itypi,itypj)
12621               fac=rrij**expon2
12622               e1=fac*fac*aa_aq(itypi,itypj)
12623               e2=fac*bb_aq(itypi,itypj)
12624               evdwij=e1+e2
12625               evdw=evdw+sss*evdwij
12626 !
12627 ! Calculate the components of the gradient in DC and X
12628 !
12629               fac=-rrij*(e1+evdwij)*sss
12630               gg(1)=xj*fac
12631               gg(2)=yj*fac
12632               gg(3)=zj*fac
12633               do k=1,3
12634                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12635                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12636                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12637                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12638               enddo
12639             endif
12640           enddo      ! j
12641         enddo        ! iint
12642       enddo          ! i
12643       do i=1,nct
12644         do j=1,3
12645           gvdwc(j,i)=expon*gvdwc(j,i)
12646           gvdwx(j,i)=expon*gvdwx(j,i)
12647         enddo
12648       enddo
12649 !******************************************************************************
12650 !
12651 !                              N O T E !!!
12652 !
12653 ! To save time, the factor of EXPON has been extracted from ALL components
12654 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12655 ! use!
12656 !
12657 !******************************************************************************
12658       return
12659       end subroutine elj_short
12660 !-----------------------------------------------------------------------------
12661       subroutine eljk_long(evdw)
12662 !
12663 ! This subroutine calculates the interaction energy of nonbonded side chains
12664 ! assuming the LJK potential of interaction.
12665 !
12666 !      implicit real*8 (a-h,o-z)
12667 !      include 'DIMENSIONS'
12668 !      include 'COMMON.GEO'
12669 !      include 'COMMON.VAR'
12670 !      include 'COMMON.LOCAL'
12671 !      include 'COMMON.CHAIN'
12672 !      include 'COMMON.DERIV'
12673 !      include 'COMMON.INTERACT'
12674 !      include 'COMMON.IOUNITS'
12675 !      include 'COMMON.NAMES'
12676       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12677       logical :: scheck
12678 !el local variables
12679       integer :: i,iint,j,k,itypi,itypi1,itypj
12680       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12681                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12682 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12683       evdw=0.0D0
12684       do i=iatsc_s,iatsc_e
12685         itypi=itype(i,1)
12686         if (itypi.eq.ntyp1) cycle
12687         itypi1=itype(i+1,1)
12688         xi=c(1,nres+i)
12689         yi=c(2,nres+i)
12690         zi=c(3,nres+i)
12691 !
12692 ! Calculate SC interaction energy.
12693 !
12694         do iint=1,nint_gr(i)
12695           do j=istart(i,iint),iend(i,iint)
12696             itypj=itype(j,1)
12697             if (itypj.eq.ntyp1) cycle
12698             xj=c(1,nres+j)-xi
12699             yj=c(2,nres+j)-yi
12700             zj=c(3,nres+j)-zi
12701             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12702             fac_augm=rrij**expon
12703             e_augm=augm(itypi,itypj)*fac_augm
12704             r_inv_ij=dsqrt(rrij)
12705             rij=1.0D0/r_inv_ij
12706             sss=sscale(rij/sigma(itypi,itypj))
12707             if (sss.lt.1.0d0) then
12708               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12709               fac=r_shift_inv**expon
12710               e1=fac*fac*aa_aq(itypi,itypj)
12711               e2=fac*bb_aq(itypi,itypj)
12712               evdwij=e_augm+e1+e2
12713 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12714 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12715 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12716 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12717 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12718 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12719 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12720               evdw=evdw+(1.0d0-sss)*evdwij
12721 !
12722 ! Calculate the components of the gradient in DC and X
12723 !
12724               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12725               fac=fac*(1.0d0-sss)
12726               gg(1)=xj*fac
12727               gg(2)=yj*fac
12728               gg(3)=zj*fac
12729               do k=1,3
12730                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12731                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12732                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12733                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12734               enddo
12735             endif
12736           enddo      ! j
12737         enddo        ! iint
12738       enddo          ! i
12739       do i=1,nct
12740         do j=1,3
12741           gvdwc(j,i)=expon*gvdwc(j,i)
12742           gvdwx(j,i)=expon*gvdwx(j,i)
12743         enddo
12744       enddo
12745       return
12746       end subroutine eljk_long
12747 !-----------------------------------------------------------------------------
12748       subroutine eljk_short(evdw)
12749 !
12750 ! This subroutine calculates the interaction energy of nonbonded side chains
12751 ! assuming the LJK potential of interaction.
12752 !
12753 !      implicit real*8 (a-h,o-z)
12754 !      include 'DIMENSIONS'
12755 !      include 'COMMON.GEO'
12756 !      include 'COMMON.VAR'
12757 !      include 'COMMON.LOCAL'
12758 !      include 'COMMON.CHAIN'
12759 !      include 'COMMON.DERIV'
12760 !      include 'COMMON.INTERACT'
12761 !      include 'COMMON.IOUNITS'
12762 !      include 'COMMON.NAMES'
12763       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12764       logical :: scheck
12765 !el local variables
12766       integer :: i,iint,j,k,itypi,itypi1,itypj
12767       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12768                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12769 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12770       evdw=0.0D0
12771       do i=iatsc_s,iatsc_e
12772         itypi=itype(i,1)
12773         if (itypi.eq.ntyp1) cycle
12774         itypi1=itype(i+1,1)
12775         xi=c(1,nres+i)
12776         yi=c(2,nres+i)
12777         zi=c(3,nres+i)
12778 !
12779 ! Calculate SC interaction energy.
12780 !
12781         do iint=1,nint_gr(i)
12782           do j=istart(i,iint),iend(i,iint)
12783             itypj=itype(j,1)
12784             if (itypj.eq.ntyp1) cycle
12785             xj=c(1,nres+j)-xi
12786             yj=c(2,nres+j)-yi
12787             zj=c(3,nres+j)-zi
12788             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12789             fac_augm=rrij**expon
12790             e_augm=augm(itypi,itypj)*fac_augm
12791             r_inv_ij=dsqrt(rrij)
12792             rij=1.0D0/r_inv_ij
12793             sss=sscale(rij/sigma(itypi,itypj))
12794             if (sss.gt.0.0d0) then
12795               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12796               fac=r_shift_inv**expon
12797               e1=fac*fac*aa_aq(itypi,itypj)
12798               e2=fac*bb_aq(itypi,itypj)
12799               evdwij=e_augm+e1+e2
12800 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12801 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12802 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12803 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12804 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12805 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12806 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12807               evdw=evdw+sss*evdwij
12808 !
12809 ! Calculate the components of the gradient in DC and X
12810 !
12811               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12812               fac=fac*sss
12813               gg(1)=xj*fac
12814               gg(2)=yj*fac
12815               gg(3)=zj*fac
12816               do k=1,3
12817                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12818                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12819                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12820                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12821               enddo
12822             endif
12823           enddo      ! j
12824         enddo        ! iint
12825       enddo          ! i
12826       do i=1,nct
12827         do j=1,3
12828           gvdwc(j,i)=expon*gvdwc(j,i)
12829           gvdwx(j,i)=expon*gvdwx(j,i)
12830         enddo
12831       enddo
12832       return
12833       end subroutine eljk_short
12834 !-----------------------------------------------------------------------------
12835       subroutine ebp_long(evdw)
12836 !
12837 ! This subroutine calculates the interaction energy of nonbonded side chains
12838 ! assuming the Berne-Pechukas potential of interaction.
12839 !
12840       use calc_data
12841 !      implicit real*8 (a-h,o-z)
12842 !      include 'DIMENSIONS'
12843 !      include 'COMMON.GEO'
12844 !      include 'COMMON.VAR'
12845 !      include 'COMMON.LOCAL'
12846 !      include 'COMMON.CHAIN'
12847 !      include 'COMMON.DERIV'
12848 !      include 'COMMON.NAMES'
12849 !      include 'COMMON.INTERACT'
12850 !      include 'COMMON.IOUNITS'
12851 !      include 'COMMON.CALC'
12852       use comm_srutu
12853 !el      integer :: icall
12854 !el      common /srutu/ icall
12855 !     double precision rrsave(maxdim)
12856       logical :: lprn
12857 !el local variables
12858       integer :: iint,itypi,itypi1,itypj
12859       real(kind=8) :: rrij,xi,yi,zi,fac
12860       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12861       evdw=0.0D0
12862 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12863       evdw=0.0D0
12864 !     if (icall.eq.0) then
12865 !       lprn=.true.
12866 !     else
12867         lprn=.false.
12868 !     endif
12869 !el      ind=0
12870       do i=iatsc_s,iatsc_e
12871         itypi=itype(i,1)
12872         if (itypi.eq.ntyp1) cycle
12873         itypi1=itype(i+1,1)
12874         xi=c(1,nres+i)
12875         yi=c(2,nres+i)
12876         zi=c(3,nres+i)
12877         dxi=dc_norm(1,nres+i)
12878         dyi=dc_norm(2,nres+i)
12879         dzi=dc_norm(3,nres+i)
12880 !        dsci_inv=dsc_inv(itypi)
12881         dsci_inv=vbld_inv(i+nres)
12882 !
12883 ! Calculate SC interaction energy.
12884 !
12885         do iint=1,nint_gr(i)
12886           do j=istart(i,iint),iend(i,iint)
12887 !el            ind=ind+1
12888             itypj=itype(j,1)
12889             if (itypj.eq.ntyp1) cycle
12890 !            dscj_inv=dsc_inv(itypj)
12891             dscj_inv=vbld_inv(j+nres)
12892             chi1=chi(itypi,itypj)
12893             chi2=chi(itypj,itypi)
12894             chi12=chi1*chi2
12895             chip1=chip(itypi)
12896             chip2=chip(itypj)
12897             chip12=chip1*chip2
12898             alf1=alp(itypi)
12899             alf2=alp(itypj)
12900             alf12=0.5D0*(alf1+alf2)
12901             xj=c(1,nres+j)-xi
12902             yj=c(2,nres+j)-yi
12903             zj=c(3,nres+j)-zi
12904             dxj=dc_norm(1,nres+j)
12905             dyj=dc_norm(2,nres+j)
12906             dzj=dc_norm(3,nres+j)
12907             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12908             rij=dsqrt(rrij)
12909             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12910
12911             if (sss.lt.1.0d0) then
12912
12913 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12914               call sc_angular
12915 ! Calculate whole angle-dependent part of epsilon and contributions
12916 ! to its derivatives
12917               fac=(rrij*sigsq)**expon2
12918               e1=fac*fac*aa_aq(itypi,itypj)
12919               e2=fac*bb_aq(itypi,itypj)
12920               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12921               eps2der=evdwij*eps3rt
12922               eps3der=evdwij*eps2rt
12923               evdwij=evdwij*eps2rt*eps3rt
12924               evdw=evdw+evdwij*(1.0d0-sss)
12925               if (lprn) then
12926               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12927               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12928 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12929 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12930 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12931 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12932 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12933 !d     &          evdwij
12934               endif
12935 ! Calculate gradient components.
12936               e1=e1*eps1*eps2rt**2*eps3rt**2
12937               fac=-expon*(e1+evdwij)
12938               sigder=fac/sigsq
12939               fac=rrij*fac
12940 ! Calculate radial part of the gradient
12941               gg(1)=xj*fac
12942               gg(2)=yj*fac
12943               gg(3)=zj*fac
12944 ! Calculate the angular part of the gradient and sum add the contributions
12945 ! to the appropriate components of the Cartesian gradient.
12946               call sc_grad_scale(1.0d0-sss)
12947             endif
12948           enddo      ! j
12949         enddo        ! iint
12950       enddo          ! i
12951 !     stop
12952       return
12953       end subroutine ebp_long
12954 !-----------------------------------------------------------------------------
12955       subroutine ebp_short(evdw)
12956 !
12957 ! This subroutine calculates the interaction energy of nonbonded side chains
12958 ! assuming the Berne-Pechukas potential of interaction.
12959 !
12960       use calc_data
12961 !      implicit real*8 (a-h,o-z)
12962 !      include 'DIMENSIONS'
12963 !      include 'COMMON.GEO'
12964 !      include 'COMMON.VAR'
12965 !      include 'COMMON.LOCAL'
12966 !      include 'COMMON.CHAIN'
12967 !      include 'COMMON.DERIV'
12968 !      include 'COMMON.NAMES'
12969 !      include 'COMMON.INTERACT'
12970 !      include 'COMMON.IOUNITS'
12971 !      include 'COMMON.CALC'
12972       use comm_srutu
12973 !el      integer :: icall
12974 !el      common /srutu/ icall
12975 !     double precision rrsave(maxdim)
12976       logical :: lprn
12977 !el local variables
12978       integer :: iint,itypi,itypi1,itypj
12979       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
12980       real(kind=8) :: sss,e1,e2,evdw
12981       evdw=0.0D0
12982 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12983       evdw=0.0D0
12984 !     if (icall.eq.0) then
12985 !       lprn=.true.
12986 !     else
12987         lprn=.false.
12988 !     endif
12989 !el      ind=0
12990       do i=iatsc_s,iatsc_e
12991         itypi=itype(i,1)
12992         if (itypi.eq.ntyp1) cycle
12993         itypi1=itype(i+1,1)
12994         xi=c(1,nres+i)
12995         yi=c(2,nres+i)
12996         zi=c(3,nres+i)
12997         dxi=dc_norm(1,nres+i)
12998         dyi=dc_norm(2,nres+i)
12999         dzi=dc_norm(3,nres+i)
13000 !        dsci_inv=dsc_inv(itypi)
13001         dsci_inv=vbld_inv(i+nres)
13002 !
13003 ! Calculate SC interaction energy.
13004 !
13005         do iint=1,nint_gr(i)
13006           do j=istart(i,iint),iend(i,iint)
13007 !el            ind=ind+1
13008             itypj=itype(j,1)
13009             if (itypj.eq.ntyp1) cycle
13010 !            dscj_inv=dsc_inv(itypj)
13011             dscj_inv=vbld_inv(j+nres)
13012             chi1=chi(itypi,itypj)
13013             chi2=chi(itypj,itypi)
13014             chi12=chi1*chi2
13015             chip1=chip(itypi)
13016             chip2=chip(itypj)
13017             chip12=chip1*chip2
13018             alf1=alp(itypi)
13019             alf2=alp(itypj)
13020             alf12=0.5D0*(alf1+alf2)
13021             xj=c(1,nres+j)-xi
13022             yj=c(2,nres+j)-yi
13023             zj=c(3,nres+j)-zi
13024             dxj=dc_norm(1,nres+j)
13025             dyj=dc_norm(2,nres+j)
13026             dzj=dc_norm(3,nres+j)
13027             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13028             rij=dsqrt(rrij)
13029             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13030
13031             if (sss.gt.0.0d0) then
13032
13033 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13034               call sc_angular
13035 ! Calculate whole angle-dependent part of epsilon and contributions
13036 ! to its derivatives
13037               fac=(rrij*sigsq)**expon2
13038               e1=fac*fac*aa_aq(itypi,itypj)
13039               e2=fac*bb_aq(itypi,itypj)
13040               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13041               eps2der=evdwij*eps3rt
13042               eps3der=evdwij*eps2rt
13043               evdwij=evdwij*eps2rt*eps3rt
13044               evdw=evdw+evdwij*sss
13045               if (lprn) then
13046               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13047               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13048 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13049 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13050 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13051 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13052 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13053 !d     &          evdwij
13054               endif
13055 ! Calculate gradient components.
13056               e1=e1*eps1*eps2rt**2*eps3rt**2
13057               fac=-expon*(e1+evdwij)
13058               sigder=fac/sigsq
13059               fac=rrij*fac
13060 ! Calculate radial part of the gradient
13061               gg(1)=xj*fac
13062               gg(2)=yj*fac
13063               gg(3)=zj*fac
13064 ! Calculate the angular part of the gradient and sum add the contributions
13065 ! to the appropriate components of the Cartesian gradient.
13066               call sc_grad_scale(sss)
13067             endif
13068           enddo      ! j
13069         enddo        ! iint
13070       enddo          ! i
13071 !     stop
13072       return
13073       end subroutine ebp_short
13074 !-----------------------------------------------------------------------------
13075       subroutine egb_long(evdw)
13076 !
13077 ! This subroutine calculates the interaction energy of nonbonded side chains
13078 ! assuming the Gay-Berne potential of interaction.
13079 !
13080       use calc_data
13081 !      implicit real*8 (a-h,o-z)
13082 !      include 'DIMENSIONS'
13083 !      include 'COMMON.GEO'
13084 !      include 'COMMON.VAR'
13085 !      include 'COMMON.LOCAL'
13086 !      include 'COMMON.CHAIN'
13087 !      include 'COMMON.DERIV'
13088 !      include 'COMMON.NAMES'
13089 !      include 'COMMON.INTERACT'
13090 !      include 'COMMON.IOUNITS'
13091 !      include 'COMMON.CALC'
13092 !      include 'COMMON.CONTROL'
13093       logical :: lprn
13094 !el local variables
13095       integer :: iint,itypi,itypi1,itypj,subchap
13096       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13097       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13098       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13099                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13100                     ssgradlipi,ssgradlipj
13101
13102
13103       evdw=0.0D0
13104 !cccc      energy_dec=.false.
13105 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13106       evdw=0.0D0
13107       lprn=.false.
13108 !     if (icall.eq.0) lprn=.false.
13109 !el      ind=0
13110       do i=iatsc_s,iatsc_e
13111         itypi=itype(i,1)
13112         if (itypi.eq.ntyp1) cycle
13113         itypi1=itype(i+1,1)
13114         xi=c(1,nres+i)
13115         yi=c(2,nres+i)
13116         zi=c(3,nres+i)
13117           xi=mod(xi,boxxsize)
13118           if (xi.lt.0) xi=xi+boxxsize
13119           yi=mod(yi,boxysize)
13120           if (yi.lt.0) yi=yi+boxysize
13121           zi=mod(zi,boxzsize)
13122           if (zi.lt.0) zi=zi+boxzsize
13123        if ((zi.gt.bordlipbot)    &
13124         .and.(zi.lt.bordliptop)) then
13125 !C the energy transfer exist
13126         if (zi.lt.buflipbot) then
13127 !C what fraction I am in
13128          fracinbuf=1.0d0-    &
13129              ((zi-bordlipbot)/lipbufthick)
13130 !C lipbufthick is thickenes of lipid buffore
13131          sslipi=sscalelip(fracinbuf)
13132          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13133         elseif (zi.gt.bufliptop) then
13134          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13135          sslipi=sscalelip(fracinbuf)
13136          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13137         else
13138          sslipi=1.0d0
13139          ssgradlipi=0.0
13140         endif
13141        else
13142          sslipi=0.0d0
13143          ssgradlipi=0.0
13144        endif
13145
13146         dxi=dc_norm(1,nres+i)
13147         dyi=dc_norm(2,nres+i)
13148         dzi=dc_norm(3,nres+i)
13149 !        dsci_inv=dsc_inv(itypi)
13150         dsci_inv=vbld_inv(i+nres)
13151 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13152 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13153 !
13154 ! Calculate SC interaction energy.
13155 !
13156         do iint=1,nint_gr(i)
13157           do j=istart(i,iint),iend(i,iint)
13158             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13159 !              call dyn_ssbond_ene(i,j,evdwij)
13160 !              evdw=evdw+evdwij
13161 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13162 !                              'evdw',i,j,evdwij,' ss'
13163 !              if (energy_dec) write (iout,*) &
13164 !                              'evdw',i,j,evdwij,' ss'
13165 !             do k=j+1,iend(i,iint)
13166 !C search over all next residues
13167 !              if (dyn_ss_mask(k)) then
13168 !C check if they are cysteins
13169 !C              write(iout,*) 'k=',k
13170
13171 !c              write(iout,*) "PRZED TRI", evdwij
13172 !               evdwij_przed_tri=evdwij
13173 !              call triple_ssbond_ene(i,j,k,evdwij)
13174 !c               if(evdwij_przed_tri.ne.evdwij) then
13175 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13176 !c               endif
13177
13178 !c              write(iout,*) "PO TRI", evdwij
13179 !C call the energy function that removes the artifical triple disulfide
13180 !C bond the soubroutine is located in ssMD.F
13181 !              evdw=evdw+evdwij
13182               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13183                             'evdw',i,j,evdwij,'tss'
13184 !              endif!dyn_ss_mask(k)
13185 !             enddo! k
13186
13187             ELSE
13188 !el            ind=ind+1
13189             itypj=itype(j,1)
13190             if (itypj.eq.ntyp1) cycle
13191 !            dscj_inv=dsc_inv(itypj)
13192             dscj_inv=vbld_inv(j+nres)
13193 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13194 !     &       1.0d0/vbld(j+nres)
13195 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13196             sig0ij=sigma(itypi,itypj)
13197             chi1=chi(itypi,itypj)
13198             chi2=chi(itypj,itypi)
13199             chi12=chi1*chi2
13200             chip1=chip(itypi)
13201             chip2=chip(itypj)
13202             chip12=chip1*chip2
13203             alf1=alp(itypi)
13204             alf2=alp(itypj)
13205             alf12=0.5D0*(alf1+alf2)
13206             xj=c(1,nres+j)
13207             yj=c(2,nres+j)
13208             zj=c(3,nres+j)
13209 ! Searching for nearest neighbour
13210           xj=mod(xj,boxxsize)
13211           if (xj.lt.0) xj=xj+boxxsize
13212           yj=mod(yj,boxysize)
13213           if (yj.lt.0) yj=yj+boxysize
13214           zj=mod(zj,boxzsize)
13215           if (zj.lt.0) zj=zj+boxzsize
13216        if ((zj.gt.bordlipbot)   &
13217       .and.(zj.lt.bordliptop)) then
13218 !C the energy transfer exist
13219         if (zj.lt.buflipbot) then
13220 !C what fraction I am in
13221          fracinbuf=1.0d0-  &
13222              ((zj-bordlipbot)/lipbufthick)
13223 !C lipbufthick is thickenes of lipid buffore
13224          sslipj=sscalelip(fracinbuf)
13225          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13226         elseif (zj.gt.bufliptop) then
13227          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13228          sslipj=sscalelip(fracinbuf)
13229          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13230         else
13231          sslipj=1.0d0
13232          ssgradlipj=0.0
13233         endif
13234        else
13235          sslipj=0.0d0
13236          ssgradlipj=0.0
13237        endif
13238       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13239        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13240       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13241        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13242
13243           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13244           xj_safe=xj
13245           yj_safe=yj
13246           zj_safe=zj
13247           subchap=0
13248           do xshift=-1,1
13249           do yshift=-1,1
13250           do zshift=-1,1
13251           xj=xj_safe+xshift*boxxsize
13252           yj=yj_safe+yshift*boxysize
13253           zj=zj_safe+zshift*boxzsize
13254           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13255           if(dist_temp.lt.dist_init) then
13256             dist_init=dist_temp
13257             xj_temp=xj
13258             yj_temp=yj
13259             zj_temp=zj
13260             subchap=1
13261           endif
13262           enddo
13263           enddo
13264           enddo
13265           if (subchap.eq.1) then
13266           xj=xj_temp-xi
13267           yj=yj_temp-yi
13268           zj=zj_temp-zi
13269           else
13270           xj=xj_safe-xi
13271           yj=yj_safe-yi
13272           zj=zj_safe-zi
13273           endif
13274
13275             dxj=dc_norm(1,nres+j)
13276             dyj=dc_norm(2,nres+j)
13277             dzj=dc_norm(3,nres+j)
13278             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13279             rij=dsqrt(rrij)
13280             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13281             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13282             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13283             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13284             if (sss_ele_cut.le.0.0) cycle
13285             if (sss.lt.1.0d0) then
13286
13287 ! Calculate angle-dependent terms of energy and contributions to their
13288 ! derivatives.
13289               call sc_angular
13290               sigsq=1.0D0/sigsq
13291               sig=sig0ij*dsqrt(sigsq)
13292               rij_shift=1.0D0/rij-sig+sig0ij
13293 ! for diagnostics; uncomment
13294 !              rij_shift=1.2*sig0ij
13295 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13296               if (rij_shift.le.0.0D0) then
13297                 evdw=1.0D20
13298 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13299 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13300 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13301                 return
13302               endif
13303               sigder=-sig*sigsq
13304 !---------------------------------------------------------------
13305               rij_shift=1.0D0/rij_shift
13306               fac=rij_shift**expon
13307               e1=fac*fac*aa
13308               e2=fac*bb
13309               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13310               eps2der=evdwij*eps3rt
13311               eps3der=evdwij*eps2rt
13312 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13313 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13314               evdwij=evdwij*eps2rt*eps3rt
13315               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13316               if (lprn) then
13317               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13318               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13319               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13320                 restyp(itypi,1),i,restyp(itypj,1),j,&
13321                 epsi,sigm,chi1,chi2,chip1,chip2,&
13322                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13323                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13324                 evdwij
13325               endif
13326
13327               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13328                               'evdw',i,j,evdwij
13329 !              if (energy_dec) write (iout,*) &
13330 !                              'evdw',i,j,evdwij,"egb_long"
13331
13332 ! Calculate gradient components.
13333               e1=e1*eps1*eps2rt**2*eps3rt**2
13334               fac=-expon*(e1+evdwij)*rij_shift
13335               sigder=fac*sigder
13336               fac=rij*fac
13337               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13338             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13339             /sigmaii(itypi,itypj))
13340 !              fac=0.0d0
13341 ! Calculate the radial part of the gradient
13342               gg(1)=xj*fac
13343               gg(2)=yj*fac
13344               gg(3)=zj*fac
13345 ! Calculate angular part of the gradient.
13346               call sc_grad_scale(1.0d0-sss)
13347             ENDIF    !mask_dyn_ss
13348             endif
13349           enddo      ! j
13350         enddo        ! iint
13351       enddo          ! i
13352 !      write (iout,*) "Number of loop steps in EGB:",ind
13353 !ccc      energy_dec=.false.
13354       return
13355       end subroutine egb_long
13356 !-----------------------------------------------------------------------------
13357       subroutine egb_short(evdw)
13358 !
13359 ! This subroutine calculates the interaction energy of nonbonded side chains
13360 ! assuming the Gay-Berne potential of interaction.
13361 !
13362       use calc_data
13363 !      implicit real*8 (a-h,o-z)
13364 !      include 'DIMENSIONS'
13365 !      include 'COMMON.GEO'
13366 !      include 'COMMON.VAR'
13367 !      include 'COMMON.LOCAL'
13368 !      include 'COMMON.CHAIN'
13369 !      include 'COMMON.DERIV'
13370 !      include 'COMMON.NAMES'
13371 !      include 'COMMON.INTERACT'
13372 !      include 'COMMON.IOUNITS'
13373 !      include 'COMMON.CALC'
13374 !      include 'COMMON.CONTROL'
13375       logical :: lprn
13376 !el local variables
13377       integer :: iint,itypi,itypi1,itypj,subchap
13378       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13379       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13380       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13381                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13382                     ssgradlipi,ssgradlipj
13383       evdw=0.0D0
13384 !cccc      energy_dec=.false.
13385 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13386       evdw=0.0D0
13387       lprn=.false.
13388 !     if (icall.eq.0) lprn=.false.
13389 !el      ind=0
13390       do i=iatsc_s,iatsc_e
13391         itypi=itype(i,1)
13392         if (itypi.eq.ntyp1) cycle
13393         itypi1=itype(i+1,1)
13394         xi=c(1,nres+i)
13395         yi=c(2,nres+i)
13396         zi=c(3,nres+i)
13397           xi=mod(xi,boxxsize)
13398           if (xi.lt.0) xi=xi+boxxsize
13399           yi=mod(yi,boxysize)
13400           if (yi.lt.0) yi=yi+boxysize
13401           zi=mod(zi,boxzsize)
13402           if (zi.lt.0) zi=zi+boxzsize
13403        if ((zi.gt.bordlipbot)    &
13404         .and.(zi.lt.bordliptop)) then
13405 !C the energy transfer exist
13406         if (zi.lt.buflipbot) then
13407 !C what fraction I am in
13408          fracinbuf=1.0d0-    &
13409              ((zi-bordlipbot)/lipbufthick)
13410 !C lipbufthick is thickenes of lipid buffore
13411          sslipi=sscalelip(fracinbuf)
13412          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13413         elseif (zi.gt.bufliptop) then
13414          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13415          sslipi=sscalelip(fracinbuf)
13416          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13417         else
13418          sslipi=1.0d0
13419          ssgradlipi=0.0
13420         endif
13421        else
13422          sslipi=0.0d0
13423          ssgradlipi=0.0
13424        endif
13425
13426         dxi=dc_norm(1,nres+i)
13427         dyi=dc_norm(2,nres+i)
13428         dzi=dc_norm(3,nres+i)
13429 !        dsci_inv=dsc_inv(itypi)
13430         dsci_inv=vbld_inv(i+nres)
13431
13432         dxi=dc_norm(1,nres+i)
13433         dyi=dc_norm(2,nres+i)
13434         dzi=dc_norm(3,nres+i)
13435 !        dsci_inv=dsc_inv(itypi)
13436         dsci_inv=vbld_inv(i+nres)
13437 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13438 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13439 !
13440 ! Calculate SC interaction energy.
13441 !
13442         do iint=1,nint_gr(i)
13443           do j=istart(i,iint),iend(i,iint)
13444             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13445               call dyn_ssbond_ene(i,j,evdwij)
13446               evdw=evdw+evdwij
13447               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13448                               'evdw',i,j,evdwij,' ss'
13449              do k=j+1,iend(i,iint)
13450 !C search over all next residues
13451               if (dyn_ss_mask(k)) then
13452 !C check if they are cysteins
13453 !C              write(iout,*) 'k=',k
13454
13455 !c              write(iout,*) "PRZED TRI", evdwij
13456 !               evdwij_przed_tri=evdwij
13457               call triple_ssbond_ene(i,j,k,evdwij)
13458 !c               if(evdwij_przed_tri.ne.evdwij) then
13459 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13460 !c               endif
13461
13462 !c              write(iout,*) "PO TRI", evdwij
13463 !C call the energy function that removes the artifical triple disulfide
13464 !C bond the soubroutine is located in ssMD.F
13465               evdw=evdw+evdwij
13466               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13467                             'evdw',i,j,evdwij,'tss'
13468               endif!dyn_ss_mask(k)
13469              enddo! k
13470
13471 !              if (energy_dec) write (iout,*) &
13472 !                              'evdw',i,j,evdwij,' ss'
13473             ELSE
13474 !el            ind=ind+1
13475             itypj=itype(j,1)
13476             if (itypj.eq.ntyp1) cycle
13477 !            dscj_inv=dsc_inv(itypj)
13478             dscj_inv=vbld_inv(j+nres)
13479 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13480 !     &       1.0d0/vbld(j+nres)
13481 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13482             sig0ij=sigma(itypi,itypj)
13483             chi1=chi(itypi,itypj)
13484             chi2=chi(itypj,itypi)
13485             chi12=chi1*chi2
13486             chip1=chip(itypi)
13487             chip2=chip(itypj)
13488             chip12=chip1*chip2
13489             alf1=alp(itypi)
13490             alf2=alp(itypj)
13491             alf12=0.5D0*(alf1+alf2)
13492 !            xj=c(1,nres+j)-xi
13493 !            yj=c(2,nres+j)-yi
13494 !            zj=c(3,nres+j)-zi
13495             xj=c(1,nres+j)
13496             yj=c(2,nres+j)
13497             zj=c(3,nres+j)
13498 ! Searching for nearest neighbour
13499           xj=mod(xj,boxxsize)
13500           if (xj.lt.0) xj=xj+boxxsize
13501           yj=mod(yj,boxysize)
13502           if (yj.lt.0) yj=yj+boxysize
13503           zj=mod(zj,boxzsize)
13504           if (zj.lt.0) zj=zj+boxzsize
13505        if ((zj.gt.bordlipbot)   &
13506       .and.(zj.lt.bordliptop)) then
13507 !C the energy transfer exist
13508         if (zj.lt.buflipbot) then
13509 !C what fraction I am in
13510          fracinbuf=1.0d0-  &
13511              ((zj-bordlipbot)/lipbufthick)
13512 !C lipbufthick is thickenes of lipid buffore
13513          sslipj=sscalelip(fracinbuf)
13514          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13515         elseif (zj.gt.bufliptop) then
13516          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13517          sslipj=sscalelip(fracinbuf)
13518          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13519         else
13520          sslipj=1.0d0
13521          ssgradlipj=0.0
13522         endif
13523        else
13524          sslipj=0.0d0
13525          ssgradlipj=0.0
13526        endif
13527       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13528        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13529       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13530        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13531
13532           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13533           xj_safe=xj
13534           yj_safe=yj
13535           zj_safe=zj
13536           subchap=0
13537
13538           do xshift=-1,1
13539           do yshift=-1,1
13540           do zshift=-1,1
13541           xj=xj_safe+xshift*boxxsize
13542           yj=yj_safe+yshift*boxysize
13543           zj=zj_safe+zshift*boxzsize
13544           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13545           if(dist_temp.lt.dist_init) then
13546             dist_init=dist_temp
13547             xj_temp=xj
13548             yj_temp=yj
13549             zj_temp=zj
13550             subchap=1
13551           endif
13552           enddo
13553           enddo
13554           enddo
13555           if (subchap.eq.1) then
13556           xj=xj_temp-xi
13557           yj=yj_temp-yi
13558           zj=zj_temp-zi
13559           else
13560           xj=xj_safe-xi
13561           yj=yj_safe-yi
13562           zj=zj_safe-zi
13563           endif
13564
13565             dxj=dc_norm(1,nres+j)
13566             dyj=dc_norm(2,nres+j)
13567             dzj=dc_norm(3,nres+j)
13568             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13569             rij=dsqrt(rrij)
13570             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13571             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13572             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13573             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13574             if (sss_ele_cut.le.0.0) cycle
13575
13576             if (sss.gt.0.0d0) then
13577
13578 ! Calculate angle-dependent terms of energy and contributions to their
13579 ! derivatives.
13580               call sc_angular
13581               sigsq=1.0D0/sigsq
13582               sig=sig0ij*dsqrt(sigsq)
13583               rij_shift=1.0D0/rij-sig+sig0ij
13584 ! for diagnostics; uncomment
13585 !              rij_shift=1.2*sig0ij
13586 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13587               if (rij_shift.le.0.0D0) then
13588                 evdw=1.0D20
13589 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13590 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13591 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13592                 return
13593               endif
13594               sigder=-sig*sigsq
13595 !---------------------------------------------------------------
13596               rij_shift=1.0D0/rij_shift
13597               fac=rij_shift**expon
13598               e1=fac*fac*aa
13599               e2=fac*bb
13600               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13601               eps2der=evdwij*eps3rt
13602               eps3der=evdwij*eps2rt
13603 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13604 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13605               evdwij=evdwij*eps2rt*eps3rt
13606               evdw=evdw+evdwij*sss*sss_ele_cut
13607               if (lprn) then
13608               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13609               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13610               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13611                 restyp(itypi,1),i,restyp(itypj,1),j,&
13612                 epsi,sigm,chi1,chi2,chip1,chip2,&
13613                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13614                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13615                 evdwij
13616               endif
13617
13618               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13619                               'evdw',i,j,evdwij
13620 !              if (energy_dec) write (iout,*) &
13621 !                              'evdw',i,j,evdwij,"egb_short"
13622
13623 ! Calculate gradient components.
13624               e1=e1*eps1*eps2rt**2*eps3rt**2
13625               fac=-expon*(e1+evdwij)*rij_shift
13626               sigder=fac*sigder
13627               fac=rij*fac
13628               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13629             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13630             /sigmaii(itypi,itypj))
13631
13632 !              fac=0.0d0
13633 ! Calculate the radial part of the gradient
13634               gg(1)=xj*fac
13635               gg(2)=yj*fac
13636               gg(3)=zj*fac
13637 ! Calculate angular part of the gradient.
13638               call sc_grad_scale(sss)
13639             endif
13640           ENDIF !mask_dyn_ss
13641           enddo      ! j
13642         enddo        ! iint
13643       enddo          ! i
13644 !      write (iout,*) "Number of loop steps in EGB:",ind
13645 !ccc      energy_dec=.false.
13646       return
13647       end subroutine egb_short
13648 !-----------------------------------------------------------------------------
13649       subroutine egbv_long(evdw)
13650 !
13651 ! This subroutine calculates the interaction energy of nonbonded side chains
13652 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13653 !
13654       use calc_data
13655 !      implicit real*8 (a-h,o-z)
13656 !      include 'DIMENSIONS'
13657 !      include 'COMMON.GEO'
13658 !      include 'COMMON.VAR'
13659 !      include 'COMMON.LOCAL'
13660 !      include 'COMMON.CHAIN'
13661 !      include 'COMMON.DERIV'
13662 !      include 'COMMON.NAMES'
13663 !      include 'COMMON.INTERACT'
13664 !      include 'COMMON.IOUNITS'
13665 !      include 'COMMON.CALC'
13666       use comm_srutu
13667 !el      integer :: icall
13668 !el      common /srutu/ icall
13669       logical :: lprn
13670 !el local variables
13671       integer :: iint,itypi,itypi1,itypj
13672       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13673       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13674       evdw=0.0D0
13675 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13676       evdw=0.0D0
13677       lprn=.false.
13678 !     if (icall.eq.0) lprn=.true.
13679 !el      ind=0
13680       do i=iatsc_s,iatsc_e
13681         itypi=itype(i,1)
13682         if (itypi.eq.ntyp1) cycle
13683         itypi1=itype(i+1,1)
13684         xi=c(1,nres+i)
13685         yi=c(2,nres+i)
13686         zi=c(3,nres+i)
13687         dxi=dc_norm(1,nres+i)
13688         dyi=dc_norm(2,nres+i)
13689         dzi=dc_norm(3,nres+i)
13690 !        dsci_inv=dsc_inv(itypi)
13691         dsci_inv=vbld_inv(i+nres)
13692 !
13693 ! Calculate SC interaction energy.
13694 !
13695         do iint=1,nint_gr(i)
13696           do j=istart(i,iint),iend(i,iint)
13697 !el            ind=ind+1
13698             itypj=itype(j,1)
13699             if (itypj.eq.ntyp1) cycle
13700 !            dscj_inv=dsc_inv(itypj)
13701             dscj_inv=vbld_inv(j+nres)
13702             sig0ij=sigma(itypi,itypj)
13703             r0ij=r0(itypi,itypj)
13704             chi1=chi(itypi,itypj)
13705             chi2=chi(itypj,itypi)
13706             chi12=chi1*chi2
13707             chip1=chip(itypi)
13708             chip2=chip(itypj)
13709             chip12=chip1*chip2
13710             alf1=alp(itypi)
13711             alf2=alp(itypj)
13712             alf12=0.5D0*(alf1+alf2)
13713             xj=c(1,nres+j)-xi
13714             yj=c(2,nres+j)-yi
13715             zj=c(3,nres+j)-zi
13716             dxj=dc_norm(1,nres+j)
13717             dyj=dc_norm(2,nres+j)
13718             dzj=dc_norm(3,nres+j)
13719             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13720             rij=dsqrt(rrij)
13721
13722             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13723
13724             if (sss.lt.1.0d0) then
13725
13726 ! Calculate angle-dependent terms of energy and contributions to their
13727 ! derivatives.
13728               call sc_angular
13729               sigsq=1.0D0/sigsq
13730               sig=sig0ij*dsqrt(sigsq)
13731               rij_shift=1.0D0/rij-sig+r0ij
13732 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13733               if (rij_shift.le.0.0D0) then
13734                 evdw=1.0D20
13735                 return
13736               endif
13737               sigder=-sig*sigsq
13738 !---------------------------------------------------------------
13739               rij_shift=1.0D0/rij_shift
13740               fac=rij_shift**expon
13741               e1=fac*fac*aa_aq(itypi,itypj)
13742               e2=fac*bb_aq(itypi,itypj)
13743               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13744               eps2der=evdwij*eps3rt
13745               eps3der=evdwij*eps2rt
13746               fac_augm=rrij**expon
13747               e_augm=augm(itypi,itypj)*fac_augm
13748               evdwij=evdwij*eps2rt*eps3rt
13749               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13750               if (lprn) then
13751               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13752               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13753               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13754                 restyp(itypi,1),i,restyp(itypj,1),j,&
13755                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13756                 chi1,chi2,chip1,chip2,&
13757                 eps1,eps2rt**2,eps3rt**2,&
13758                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13759                 evdwij+e_augm
13760               endif
13761 ! Calculate gradient components.
13762               e1=e1*eps1*eps2rt**2*eps3rt**2
13763               fac=-expon*(e1+evdwij)*rij_shift
13764               sigder=fac*sigder
13765               fac=rij*fac-2*expon*rrij*e_augm
13766 ! Calculate the radial part of the gradient
13767               gg(1)=xj*fac
13768               gg(2)=yj*fac
13769               gg(3)=zj*fac
13770 ! Calculate angular part of the gradient.
13771               call sc_grad_scale(1.0d0-sss)
13772             endif
13773           enddo      ! j
13774         enddo        ! iint
13775       enddo          ! i
13776       end subroutine egbv_long
13777 !-----------------------------------------------------------------------------
13778       subroutine egbv_short(evdw)
13779 !
13780 ! This subroutine calculates the interaction energy of nonbonded side chains
13781 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13782 !
13783       use calc_data
13784 !      implicit real*8 (a-h,o-z)
13785 !      include 'DIMENSIONS'
13786 !      include 'COMMON.GEO'
13787 !      include 'COMMON.VAR'
13788 !      include 'COMMON.LOCAL'
13789 !      include 'COMMON.CHAIN'
13790 !      include 'COMMON.DERIV'
13791 !      include 'COMMON.NAMES'
13792 !      include 'COMMON.INTERACT'
13793 !      include 'COMMON.IOUNITS'
13794 !      include 'COMMON.CALC'
13795       use comm_srutu
13796 !el      integer :: icall
13797 !el      common /srutu/ icall
13798       logical :: lprn
13799 !el local variables
13800       integer :: iint,itypi,itypi1,itypj
13801       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13802       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13803       evdw=0.0D0
13804 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13805       evdw=0.0D0
13806       lprn=.false.
13807 !     if (icall.eq.0) lprn=.true.
13808 !el      ind=0
13809       do i=iatsc_s,iatsc_e
13810         itypi=itype(i,1)
13811         if (itypi.eq.ntyp1) cycle
13812         itypi1=itype(i+1,1)
13813         xi=c(1,nres+i)
13814         yi=c(2,nres+i)
13815         zi=c(3,nres+i)
13816         dxi=dc_norm(1,nres+i)
13817         dyi=dc_norm(2,nres+i)
13818         dzi=dc_norm(3,nres+i)
13819 !        dsci_inv=dsc_inv(itypi)
13820         dsci_inv=vbld_inv(i+nres)
13821 !
13822 ! Calculate SC interaction energy.
13823 !
13824         do iint=1,nint_gr(i)
13825           do j=istart(i,iint),iend(i,iint)
13826 !el            ind=ind+1
13827             itypj=itype(j,1)
13828             if (itypj.eq.ntyp1) cycle
13829 !            dscj_inv=dsc_inv(itypj)
13830             dscj_inv=vbld_inv(j+nres)
13831             sig0ij=sigma(itypi,itypj)
13832             r0ij=r0(itypi,itypj)
13833             chi1=chi(itypi,itypj)
13834             chi2=chi(itypj,itypi)
13835             chi12=chi1*chi2
13836             chip1=chip(itypi)
13837             chip2=chip(itypj)
13838             chip12=chip1*chip2
13839             alf1=alp(itypi)
13840             alf2=alp(itypj)
13841             alf12=0.5D0*(alf1+alf2)
13842             xj=c(1,nres+j)-xi
13843             yj=c(2,nres+j)-yi
13844             zj=c(3,nres+j)-zi
13845             dxj=dc_norm(1,nres+j)
13846             dyj=dc_norm(2,nres+j)
13847             dzj=dc_norm(3,nres+j)
13848             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13849             rij=dsqrt(rrij)
13850
13851             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13852
13853             if (sss.gt.0.0d0) then
13854
13855 ! Calculate angle-dependent terms of energy and contributions to their
13856 ! derivatives.
13857               call sc_angular
13858               sigsq=1.0D0/sigsq
13859               sig=sig0ij*dsqrt(sigsq)
13860               rij_shift=1.0D0/rij-sig+r0ij
13861 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13862               if (rij_shift.le.0.0D0) then
13863                 evdw=1.0D20
13864                 return
13865               endif
13866               sigder=-sig*sigsq
13867 !---------------------------------------------------------------
13868               rij_shift=1.0D0/rij_shift
13869               fac=rij_shift**expon
13870               e1=fac*fac*aa_aq(itypi,itypj)
13871               e2=fac*bb_aq(itypi,itypj)
13872               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13873               eps2der=evdwij*eps3rt
13874               eps3der=evdwij*eps2rt
13875               fac_augm=rrij**expon
13876               e_augm=augm(itypi,itypj)*fac_augm
13877               evdwij=evdwij*eps2rt*eps3rt
13878               evdw=evdw+(evdwij+e_augm)*sss
13879               if (lprn) then
13880               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13881               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13882               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13883                 restyp(itypi,1),i,restyp(itypj,1),j,&
13884                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13885                 chi1,chi2,chip1,chip2,&
13886                 eps1,eps2rt**2,eps3rt**2,&
13887                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13888                 evdwij+e_augm
13889               endif
13890 ! Calculate gradient components.
13891               e1=e1*eps1*eps2rt**2*eps3rt**2
13892               fac=-expon*(e1+evdwij)*rij_shift
13893               sigder=fac*sigder
13894               fac=rij*fac-2*expon*rrij*e_augm
13895 ! Calculate the radial part of the gradient
13896               gg(1)=xj*fac
13897               gg(2)=yj*fac
13898               gg(3)=zj*fac
13899 ! Calculate angular part of the gradient.
13900               call sc_grad_scale(sss)
13901             endif
13902           enddo      ! j
13903         enddo        ! iint
13904       enddo          ! i
13905       end subroutine egbv_short
13906 !-----------------------------------------------------------------------------
13907       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13908 !
13909 ! This subroutine calculates the average interaction energy and its gradient
13910 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13911 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13912 ! The potential depends both on the distance of peptide-group centers and on
13913 ! the orientation of the CA-CA virtual bonds.
13914 !
13915 !      implicit real*8 (a-h,o-z)
13916
13917       use comm_locel
13918 #ifdef MPI
13919       include 'mpif.h'
13920 #endif
13921 !      include 'DIMENSIONS'
13922 !      include 'COMMON.CONTROL'
13923 !      include 'COMMON.SETUP'
13924 !      include 'COMMON.IOUNITS'
13925 !      include 'COMMON.GEO'
13926 !      include 'COMMON.VAR'
13927 !      include 'COMMON.LOCAL'
13928 !      include 'COMMON.CHAIN'
13929 !      include 'COMMON.DERIV'
13930 !      include 'COMMON.INTERACT'
13931 !      include 'COMMON.CONTACTS'
13932 !      include 'COMMON.TORSION'
13933 !      include 'COMMON.VECTORS'
13934 !      include 'COMMON.FFIELD'
13935 !      include 'COMMON.TIME1'
13936       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13937       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13938       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13939 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13940       real(kind=8),dimension(4) :: muij
13941 !el      integer :: num_conti,j1,j2
13942 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13943 !el                   dz_normi,xmedi,ymedi,zmedi
13944 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13945 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13946 !el          num_conti,j1,j2
13947 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13948 #ifdef MOMENT
13949       real(kind=8) :: scal_el=1.0d0
13950 #else
13951       real(kind=8) :: scal_el=0.5d0
13952 #endif
13953 ! 12/13/98
13954 ! 13-go grudnia roku pamietnego...
13955       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13956                                              0.0d0,1.0d0,0.0d0,&
13957                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13958 !el local variables
13959       integer :: i,j,k
13960       real(kind=8) :: fac
13961       real(kind=8) :: dxj,dyj,dzj
13962       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13963
13964 !      allocate(num_cont_hb(nres)) !(maxres)
13965 !d      write(iout,*) 'In EELEC'
13966 !d      do i=1,nloctyp
13967 !d        write(iout,*) 'Type',i
13968 !d        write(iout,*) 'B1',B1(:,i)
13969 !d        write(iout,*) 'B2',B2(:,i)
13970 !d        write(iout,*) 'CC',CC(:,:,i)
13971 !d        write(iout,*) 'DD',DD(:,:,i)
13972 !d        write(iout,*) 'EE',EE(:,:,i)
13973 !d      enddo
13974 !d      call check_vecgrad
13975 !d      stop
13976       if (icheckgrad.eq.1) then
13977         do i=1,nres-1
13978           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
13979           do k=1,3
13980             dc_norm(k,i)=dc(k,i)*fac
13981           enddo
13982 !          write (iout,*) 'i',i,' fac',fac
13983         enddo
13984       endif
13985       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
13986           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
13987           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
13988 !        call vec_and_deriv
13989 #ifdef TIMING
13990         time01=MPI_Wtime()
13991 #endif
13992 !        print *, "before set matrices"
13993         call set_matrices
13994 !        print *,"after set martices"
13995 #ifdef TIMING
13996         time_mat=time_mat+MPI_Wtime()-time01
13997 #endif
13998       endif
13999 !d      do i=1,nres-1
14000 !d        write (iout,*) 'i=',i
14001 !d        do k=1,3
14002 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14003 !d        enddo
14004 !d        do k=1,3
14005 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14006 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14007 !d        enddo
14008 !d      enddo
14009       t_eelecij=0.0d0
14010       ees=0.0D0
14011       evdw1=0.0D0
14012       eel_loc=0.0d0
14013       eello_turn3=0.0d0
14014       eello_turn4=0.0d0
14015 !el      ind=0
14016       do i=1,nres
14017         num_cont_hb(i)=0
14018       enddo
14019 !d      print '(a)','Enter EELEC'
14020 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14021 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14022 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14023       do i=1,nres
14024         gel_loc_loc(i)=0.0d0
14025         gcorr_loc(i)=0.0d0
14026       enddo
14027 !
14028 !
14029 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14030 !
14031 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14032 !
14033       do i=iturn3_start,iturn3_end
14034         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14035         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14036         dxi=dc(1,i)
14037         dyi=dc(2,i)
14038         dzi=dc(3,i)
14039         dx_normi=dc_norm(1,i)
14040         dy_normi=dc_norm(2,i)
14041         dz_normi=dc_norm(3,i)
14042         xmedi=c(1,i)+0.5d0*dxi
14043         ymedi=c(2,i)+0.5d0*dyi
14044         zmedi=c(3,i)+0.5d0*dzi
14045           xmedi=dmod(xmedi,boxxsize)
14046           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14047           ymedi=dmod(ymedi,boxysize)
14048           if (ymedi.lt.0) ymedi=ymedi+boxysize
14049           zmedi=dmod(zmedi,boxzsize)
14050           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14051         num_conti=0
14052         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14053         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14054         num_cont_hb(i)=num_conti
14055       enddo
14056       do i=iturn4_start,iturn4_end
14057         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14058           .or. itype(i+3,1).eq.ntyp1 &
14059           .or. itype(i+4,1).eq.ntyp1) cycle
14060         dxi=dc(1,i)
14061         dyi=dc(2,i)
14062         dzi=dc(3,i)
14063         dx_normi=dc_norm(1,i)
14064         dy_normi=dc_norm(2,i)
14065         dz_normi=dc_norm(3,i)
14066         xmedi=c(1,i)+0.5d0*dxi
14067         ymedi=c(2,i)+0.5d0*dyi
14068         zmedi=c(3,i)+0.5d0*dzi
14069           xmedi=dmod(xmedi,boxxsize)
14070           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14071           ymedi=dmod(ymedi,boxysize)
14072           if (ymedi.lt.0) ymedi=ymedi+boxysize
14073           zmedi=dmod(zmedi,boxzsize)
14074           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14075         num_conti=num_cont_hb(i)
14076         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14077         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14078           call eturn4(i,eello_turn4)
14079         num_cont_hb(i)=num_conti
14080       enddo   ! i
14081 !
14082 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14083 !
14084       do i=iatel_s,iatel_e
14085         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14086         dxi=dc(1,i)
14087         dyi=dc(2,i)
14088         dzi=dc(3,i)
14089         dx_normi=dc_norm(1,i)
14090         dy_normi=dc_norm(2,i)
14091         dz_normi=dc_norm(3,i)
14092         xmedi=c(1,i)+0.5d0*dxi
14093         ymedi=c(2,i)+0.5d0*dyi
14094         zmedi=c(3,i)+0.5d0*dzi
14095           xmedi=dmod(xmedi,boxxsize)
14096           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14097           ymedi=dmod(ymedi,boxysize)
14098           if (ymedi.lt.0) ymedi=ymedi+boxysize
14099           zmedi=dmod(zmedi,boxzsize)
14100           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14101 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14102         num_conti=num_cont_hb(i)
14103         do j=ielstart(i),ielend(i)
14104           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14105           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14106         enddo ! j
14107         num_cont_hb(i)=num_conti
14108       enddo   ! i
14109 !      write (iout,*) "Number of loop steps in EELEC:",ind
14110 !d      do i=1,nres
14111 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14112 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14113 !d      enddo
14114 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14115 !cc      eel_loc=eel_loc+eello_turn3
14116 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14117       return
14118       end subroutine eelec_scale
14119 !-----------------------------------------------------------------------------
14120       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14121 !      implicit real*8 (a-h,o-z)
14122
14123       use comm_locel
14124 !      include 'DIMENSIONS'
14125 #ifdef MPI
14126       include "mpif.h"
14127 #endif
14128 !      include 'COMMON.CONTROL'
14129 !      include 'COMMON.IOUNITS'
14130 !      include 'COMMON.GEO'
14131 !      include 'COMMON.VAR'
14132 !      include 'COMMON.LOCAL'
14133 !      include 'COMMON.CHAIN'
14134 !      include 'COMMON.DERIV'
14135 !      include 'COMMON.INTERACT'
14136 !      include 'COMMON.CONTACTS'
14137 !      include 'COMMON.TORSION'
14138 !      include 'COMMON.VECTORS'
14139 !      include 'COMMON.FFIELD'
14140 !      include 'COMMON.TIME1'
14141       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14142       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14143       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14144 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14145       real(kind=8),dimension(4) :: muij
14146       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14147                     dist_temp, dist_init,sss_grad
14148       integer xshift,yshift,zshift
14149
14150 !el      integer :: num_conti,j1,j2
14151 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14152 !el                   dz_normi,xmedi,ymedi,zmedi
14153 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14154 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14155 !el          num_conti,j1,j2
14156 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14157 #ifdef MOMENT
14158       real(kind=8) :: scal_el=1.0d0
14159 #else
14160       real(kind=8) :: scal_el=0.5d0
14161 #endif
14162 ! 12/13/98
14163 ! 13-go grudnia roku pamietnego...
14164       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14165                                              0.0d0,1.0d0,0.0d0,&
14166                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14167 !el local variables
14168       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14169       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14170       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14171       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14172       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14173       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14174       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14175                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14176                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14177                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14178                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14179                   ecosam,ecosbm,ecosgm,ghalf,time00
14180 !      integer :: maxconts
14181 !      maxconts = nres/4
14182 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14183 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14184 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14185 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14186 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14187 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14188 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14189 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14190 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14191 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14192 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14193 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14194 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14195
14196 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14197 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14198
14199 #ifdef MPI
14200           time00=MPI_Wtime()
14201 #endif
14202 !d      write (iout,*) "eelecij",i,j
14203 !el          ind=ind+1
14204           iteli=itel(i)
14205           itelj=itel(j)
14206           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14207           aaa=app(iteli,itelj)
14208           bbb=bpp(iteli,itelj)
14209           ael6i=ael6(iteli,itelj)
14210           ael3i=ael3(iteli,itelj)
14211           dxj=dc(1,j)
14212           dyj=dc(2,j)
14213           dzj=dc(3,j)
14214           dx_normj=dc_norm(1,j)
14215           dy_normj=dc_norm(2,j)
14216           dz_normj=dc_norm(3,j)
14217 !          xj=c(1,j)+0.5D0*dxj-xmedi
14218 !          yj=c(2,j)+0.5D0*dyj-ymedi
14219 !          zj=c(3,j)+0.5D0*dzj-zmedi
14220           xj=c(1,j)+0.5D0*dxj
14221           yj=c(2,j)+0.5D0*dyj
14222           zj=c(3,j)+0.5D0*dzj
14223           xj=mod(xj,boxxsize)
14224           if (xj.lt.0) xj=xj+boxxsize
14225           yj=mod(yj,boxysize)
14226           if (yj.lt.0) yj=yj+boxysize
14227           zj=mod(zj,boxzsize)
14228           if (zj.lt.0) zj=zj+boxzsize
14229       isubchap=0
14230       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14231       xj_safe=xj
14232       yj_safe=yj
14233       zj_safe=zj
14234       do xshift=-1,1
14235       do yshift=-1,1
14236       do zshift=-1,1
14237           xj=xj_safe+xshift*boxxsize
14238           yj=yj_safe+yshift*boxysize
14239           zj=zj_safe+zshift*boxzsize
14240           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14241           if(dist_temp.lt.dist_init) then
14242             dist_init=dist_temp
14243             xj_temp=xj
14244             yj_temp=yj
14245             zj_temp=zj
14246             isubchap=1
14247           endif
14248        enddo
14249        enddo
14250        enddo
14251        if (isubchap.eq.1) then
14252 !C          print *,i,j
14253           xj=xj_temp-xmedi
14254           yj=yj_temp-ymedi
14255           zj=zj_temp-zmedi
14256        else
14257           xj=xj_safe-xmedi
14258           yj=yj_safe-ymedi
14259           zj=zj_safe-zmedi
14260        endif
14261
14262           rij=xj*xj+yj*yj+zj*zj
14263           rrmij=1.0D0/rij
14264           rij=dsqrt(rij)
14265           rmij=1.0D0/rij
14266 ! For extracting the short-range part of Evdwpp
14267           sss=sscale(rij/rpp(iteli,itelj))
14268             sss_ele_cut=sscale_ele(rij)
14269             sss_ele_grad=sscagrad_ele(rij)
14270             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14271 !             sss_ele_cut=1.0d0
14272 !             sss_ele_grad=0.0d0
14273             if (sss_ele_cut.le.0.0) go to 128
14274
14275           r3ij=rrmij*rmij
14276           r6ij=r3ij*r3ij
14277           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14278           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14279           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14280           fac=cosa-3.0D0*cosb*cosg
14281           ev1=aaa*r6ij*r6ij
14282 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14283           if (j.eq.i+2) ev1=scal_el*ev1
14284           ev2=bbb*r6ij
14285           fac3=ael6i*r6ij
14286           fac4=ael3i*r3ij
14287           evdwij=ev1+ev2
14288           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14289           el2=fac4*fac
14290           eesij=el1+el2
14291 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14292           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14293           ees=ees+eesij*sss_ele_cut
14294           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14295 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14296 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14297 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14298 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14299
14300           if (energy_dec) then
14301               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14302               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14303           endif
14304
14305 !
14306 ! Calculate contributions to the Cartesian gradient.
14307 !
14308 #ifdef SPLITELE
14309           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14310           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14311           fac1=fac
14312           erij(1)=xj*rmij
14313           erij(2)=yj*rmij
14314           erij(3)=zj*rmij
14315 !
14316 ! Radial derivatives. First process both termini of the fragment (i,j)
14317 !
14318           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14319           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14320           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14321 !          do k=1,3
14322 !            ghalf=0.5D0*ggg(k)
14323 !            gelc(k,i)=gelc(k,i)+ghalf
14324 !            gelc(k,j)=gelc(k,j)+ghalf
14325 !          enddo
14326 ! 9/28/08 AL Gradient compotents will be summed only at the end
14327           do k=1,3
14328             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14329             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14330           enddo
14331 !
14332 ! Loop over residues i+1 thru j-1.
14333 !
14334 !grad          do k=i+1,j-1
14335 !grad            do l=1,3
14336 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14337 !grad            enddo
14338 !grad          enddo
14339           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14340           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14341           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14342           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14343           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14344           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14345 !          do k=1,3
14346 !            ghalf=0.5D0*ggg(k)
14347 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14348 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14349 !          enddo
14350 ! 9/28/08 AL Gradient compotents will be summed only at the end
14351           do k=1,3
14352             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14353             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14354           enddo
14355 !
14356 ! Loop over residues i+1 thru j-1.
14357 !
14358 !grad          do k=i+1,j-1
14359 !grad            do l=1,3
14360 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14361 !grad            enddo
14362 !grad          enddo
14363 #else
14364           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14365           facel=(el1+eesij)*sss_ele_cut
14366           fac1=fac
14367           fac=-3*rrmij*(facvdw+facvdw+facel)
14368           erij(1)=xj*rmij
14369           erij(2)=yj*rmij
14370           erij(3)=zj*rmij
14371 !
14372 ! Radial derivatives. First process both termini of the fragment (i,j)
14373 !
14374           ggg(1)=fac*xj
14375           ggg(2)=fac*yj
14376           ggg(3)=fac*zj
14377 !          do k=1,3
14378 !            ghalf=0.5D0*ggg(k)
14379 !            gelc(k,i)=gelc(k,i)+ghalf
14380 !            gelc(k,j)=gelc(k,j)+ghalf
14381 !          enddo
14382 ! 9/28/08 AL Gradient compotents will be summed only at the end
14383           do k=1,3
14384             gelc_long(k,j)=gelc(k,j)+ggg(k)
14385             gelc_long(k,i)=gelc(k,i)-ggg(k)
14386           enddo
14387 !
14388 ! Loop over residues i+1 thru j-1.
14389 !
14390 !grad          do k=i+1,j-1
14391 !grad            do l=1,3
14392 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14393 !grad            enddo
14394 !grad          enddo
14395 ! 9/28/08 AL Gradient compotents will be summed only at the end
14396           ggg(1)=facvdw*xj
14397           ggg(2)=facvdw*yj
14398           ggg(3)=facvdw*zj
14399           do k=1,3
14400             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14401             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14402           enddo
14403 #endif
14404 !
14405 ! Angular part
14406 !
14407           ecosa=2.0D0*fac3*fac1+fac4
14408           fac4=-3.0D0*fac4
14409           fac3=-6.0D0*fac3
14410           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14411           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14412           do k=1,3
14413             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14414             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14415           enddo
14416 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14417 !d   &          (dcosg(k),k=1,3)
14418           do k=1,3
14419             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14420           enddo
14421 !          do k=1,3
14422 !            ghalf=0.5D0*ggg(k)
14423 !            gelc(k,i)=gelc(k,i)+ghalf
14424 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14425 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14426 !            gelc(k,j)=gelc(k,j)+ghalf
14427 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14428 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14429 !          enddo
14430 !grad          do k=i+1,j-1
14431 !grad            do l=1,3
14432 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14433 !grad            enddo
14434 !grad          enddo
14435           do k=1,3
14436             gelc(k,i)=gelc(k,i) &
14437                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14438                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14439                      *sss_ele_cut
14440             gelc(k,j)=gelc(k,j) &
14441                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14442                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14443                      *sss_ele_cut
14444             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14445             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14446           enddo
14447           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14448               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14449               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14450 !
14451 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14452 !   energy of a peptide unit is assumed in the form of a second-order
14453 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14454 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14455 !   are computed for EVERY pair of non-contiguous peptide groups.
14456 !
14457           if (j.lt.nres-1) then
14458             j1=j+1
14459             j2=j-1
14460           else
14461             j1=j-1
14462             j2=j-2
14463           endif
14464           kkk=0
14465           do k=1,2
14466             do l=1,2
14467               kkk=kkk+1
14468               muij(kkk)=mu(k,i)*mu(l,j)
14469             enddo
14470           enddo
14471 !d         write (iout,*) 'EELEC: i',i,' j',j
14472 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14473 !d          write(iout,*) 'muij',muij
14474           ury=scalar(uy(1,i),erij)
14475           urz=scalar(uz(1,i),erij)
14476           vry=scalar(uy(1,j),erij)
14477           vrz=scalar(uz(1,j),erij)
14478           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14479           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14480           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14481           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14482           fac=dsqrt(-ael6i)*r3ij
14483           a22=a22*fac
14484           a23=a23*fac
14485           a32=a32*fac
14486           a33=a33*fac
14487 !d          write (iout,'(4i5,4f10.5)')
14488 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14489 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14490 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14491 !d     &      uy(:,j),uz(:,j)
14492 !d          write (iout,'(4f10.5)')
14493 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14494 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14495 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14496 !d           write (iout,'(9f10.5/)')
14497 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14498 ! Derivatives of the elements of A in virtual-bond vectors
14499           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14500           do k=1,3
14501             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14502             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14503             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14504             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14505             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14506             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14507             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14508             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14509             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14510             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14511             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14512             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14513           enddo
14514 ! Compute radial contributions to the gradient
14515           facr=-3.0d0*rrmij
14516           a22der=a22*facr
14517           a23der=a23*facr
14518           a32der=a32*facr
14519           a33der=a33*facr
14520           agg(1,1)=a22der*xj
14521           agg(2,1)=a22der*yj
14522           agg(3,1)=a22der*zj
14523           agg(1,2)=a23der*xj
14524           agg(2,2)=a23der*yj
14525           agg(3,2)=a23der*zj
14526           agg(1,3)=a32der*xj
14527           agg(2,3)=a32der*yj
14528           agg(3,3)=a32der*zj
14529           agg(1,4)=a33der*xj
14530           agg(2,4)=a33der*yj
14531           agg(3,4)=a33der*zj
14532 ! Add the contributions coming from er
14533           fac3=-3.0d0*fac
14534           do k=1,3
14535             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14536             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14537             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14538             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14539           enddo
14540           do k=1,3
14541 ! Derivatives in DC(i)
14542 !grad            ghalf1=0.5d0*agg(k,1)
14543 !grad            ghalf2=0.5d0*agg(k,2)
14544 !grad            ghalf3=0.5d0*agg(k,3)
14545 !grad            ghalf4=0.5d0*agg(k,4)
14546             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14547             -3.0d0*uryg(k,2)*vry)!+ghalf1
14548             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14549             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14550             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14551             -3.0d0*urzg(k,2)*vry)!+ghalf3
14552             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14553             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14554 ! Derivatives in DC(i+1)
14555             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14556             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14557             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14558             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14559             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14560             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14561             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14562             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14563 ! Derivatives in DC(j)
14564             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14565             -3.0d0*vryg(k,2)*ury)!+ghalf1
14566             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14567             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14568             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14569             -3.0d0*vryg(k,2)*urz)!+ghalf3
14570             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14571             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14572 ! Derivatives in DC(j+1) or DC(nres-1)
14573             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14574             -3.0d0*vryg(k,3)*ury)
14575             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14576             -3.0d0*vrzg(k,3)*ury)
14577             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14578             -3.0d0*vryg(k,3)*urz)
14579             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14580             -3.0d0*vrzg(k,3)*urz)
14581 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14582 !grad              do l=1,4
14583 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14584 !grad              enddo
14585 !grad            endif
14586           enddo
14587           acipa(1,1)=a22
14588           acipa(1,2)=a23
14589           acipa(2,1)=a32
14590           acipa(2,2)=a33
14591           a22=-a22
14592           a23=-a23
14593           do l=1,2
14594             do k=1,3
14595               agg(k,l)=-agg(k,l)
14596               aggi(k,l)=-aggi(k,l)
14597               aggi1(k,l)=-aggi1(k,l)
14598               aggj(k,l)=-aggj(k,l)
14599               aggj1(k,l)=-aggj1(k,l)
14600             enddo
14601           enddo
14602           if (j.lt.nres-1) then
14603             a22=-a22
14604             a32=-a32
14605             do l=1,3,2
14606               do k=1,3
14607                 agg(k,l)=-agg(k,l)
14608                 aggi(k,l)=-aggi(k,l)
14609                 aggi1(k,l)=-aggi1(k,l)
14610                 aggj(k,l)=-aggj(k,l)
14611                 aggj1(k,l)=-aggj1(k,l)
14612               enddo
14613             enddo
14614           else
14615             a22=-a22
14616             a23=-a23
14617             a32=-a32
14618             a33=-a33
14619             do l=1,4
14620               do k=1,3
14621                 agg(k,l)=-agg(k,l)
14622                 aggi(k,l)=-aggi(k,l)
14623                 aggi1(k,l)=-aggi1(k,l)
14624                 aggj(k,l)=-aggj(k,l)
14625                 aggj1(k,l)=-aggj1(k,l)
14626               enddo
14627             enddo
14628           endif
14629           ENDIF ! WCORR
14630           IF (wel_loc.gt.0.0d0) THEN
14631 ! Contribution to the local-electrostatic energy coming from the i-j pair
14632           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14633            +a33*muij(4)
14634 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14635
14636           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14637                   'eelloc',i,j,eel_loc_ij
14638 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14639
14640           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14641 ! Partial derivatives in virtual-bond dihedral angles gamma
14642           if (i.gt.1) &
14643           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14644                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14645                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14646                  *sss_ele_cut
14647           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14648                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14649                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14650                  *sss_ele_cut
14651            xtemp(1)=xj
14652            xtemp(2)=yj
14653            xtemp(3)=zj
14654
14655 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14656           do l=1,3
14657             ggg(l)=(agg(l,1)*muij(1)+ &
14658                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14659             *sss_ele_cut &
14660              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14661
14662             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14663             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14664 !grad            ghalf=0.5d0*ggg(l)
14665 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14666 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14667           enddo
14668 !grad          do k=i+1,j2
14669 !grad            do l=1,3
14670 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14671 !grad            enddo
14672 !grad          enddo
14673 ! Remaining derivatives of eello
14674           do l=1,3
14675             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14676                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14677             *sss_ele_cut
14678
14679             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14680                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14681             *sss_ele_cut
14682
14683             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14684                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14685             *sss_ele_cut
14686
14687             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14688                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14689             *sss_ele_cut
14690
14691           enddo
14692           ENDIF
14693 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14694 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14695           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14696              .and. num_conti.le.maxconts) then
14697 !            write (iout,*) i,j," entered corr"
14698 !
14699 ! Calculate the contact function. The ith column of the array JCONT will
14700 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14701 ! greater than I). The arrays FACONT and GACONT will contain the values of
14702 ! the contact function and its derivative.
14703 !           r0ij=1.02D0*rpp(iteli,itelj)
14704 !           r0ij=1.11D0*rpp(iteli,itelj)
14705             r0ij=2.20D0*rpp(iteli,itelj)
14706 !           r0ij=1.55D0*rpp(iteli,itelj)
14707             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14708 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14709             if (fcont.gt.0.0D0) then
14710               num_conti=num_conti+1
14711               if (num_conti.gt.maxconts) then
14712 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14713                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14714                                ' will skip next contacts for this conf.',num_conti
14715               else
14716                 jcont_hb(num_conti,i)=j
14717 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14718 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14719                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14720                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14721 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14722 !  terms.
14723                 d_cont(num_conti,i)=rij
14724 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14725 !     --- Electrostatic-interaction matrix ---
14726                 a_chuj(1,1,num_conti,i)=a22
14727                 a_chuj(1,2,num_conti,i)=a23
14728                 a_chuj(2,1,num_conti,i)=a32
14729                 a_chuj(2,2,num_conti,i)=a33
14730 !     --- Gradient of rij
14731                 do kkk=1,3
14732                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14733                 enddo
14734                 kkll=0
14735                 do k=1,2
14736                   do l=1,2
14737                     kkll=kkll+1
14738                     do m=1,3
14739                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14740                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14741                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14742                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14743                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14744                     enddo
14745                   enddo
14746                 enddo
14747                 ENDIF
14748                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14749 ! Calculate contact energies
14750                 cosa4=4.0D0*cosa
14751                 wij=cosa-3.0D0*cosb*cosg
14752                 cosbg1=cosb+cosg
14753                 cosbg2=cosb-cosg
14754 !               fac3=dsqrt(-ael6i)/r0ij**3
14755                 fac3=dsqrt(-ael6i)*r3ij
14756 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14757                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14758                 if (ees0tmp.gt.0) then
14759                   ees0pij=dsqrt(ees0tmp)
14760                 else
14761                   ees0pij=0
14762                 endif
14763 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14764                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14765                 if (ees0tmp.gt.0) then
14766                   ees0mij=dsqrt(ees0tmp)
14767                 else
14768                   ees0mij=0
14769                 endif
14770 !               ees0mij=0.0D0
14771                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14772                      *sss_ele_cut
14773
14774                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14775                      *sss_ele_cut
14776
14777 ! Diagnostics. Comment out or remove after debugging!
14778 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14779 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14780 !               ees0m(num_conti,i)=0.0D0
14781 ! End diagnostics.
14782 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14783 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14784 ! Angular derivatives of the contact function
14785                 ees0pij1=fac3/ees0pij
14786                 ees0mij1=fac3/ees0mij
14787                 fac3p=-3.0D0*fac3*rrmij
14788                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14789                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14790 !               ees0mij1=0.0D0
14791                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14792                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14793                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14794                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14795                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14796                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14797                 ecosap=ecosa1+ecosa2
14798                 ecosbp=ecosb1+ecosb2
14799                 ecosgp=ecosg1+ecosg2
14800                 ecosam=ecosa1-ecosa2
14801                 ecosbm=ecosb1-ecosb2
14802                 ecosgm=ecosg1-ecosg2
14803 ! Diagnostics
14804 !               ecosap=ecosa1
14805 !               ecosbp=ecosb1
14806 !               ecosgp=ecosg1
14807 !               ecosam=0.0D0
14808 !               ecosbm=0.0D0
14809 !               ecosgm=0.0D0
14810 ! End diagnostics
14811                 facont_hb(num_conti,i)=fcont
14812                 fprimcont=fprimcont/rij
14813 !d              facont_hb(num_conti,i)=1.0D0
14814 ! Following line is for diagnostics.
14815 !d              fprimcont=0.0D0
14816                 do k=1,3
14817                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14818                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14819                 enddo
14820                 do k=1,3
14821                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14822                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14823                 enddo
14824 !                gggp(1)=gggp(1)+ees0pijp*xj
14825 !                gggp(2)=gggp(2)+ees0pijp*yj
14826 !                gggp(3)=gggp(3)+ees0pijp*zj
14827 !                gggm(1)=gggm(1)+ees0mijp*xj
14828 !                gggm(2)=gggm(2)+ees0mijp*yj
14829 !                gggm(3)=gggm(3)+ees0mijp*zj
14830                 gggp(1)=gggp(1)+ees0pijp*xj &
14831                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14832                 gggp(2)=gggp(2)+ees0pijp*yj &
14833                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14834                 gggp(3)=gggp(3)+ees0pijp*zj &
14835                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14836
14837                 gggm(1)=gggm(1)+ees0mijp*xj &
14838                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14839
14840                 gggm(2)=gggm(2)+ees0mijp*yj &
14841                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14842
14843                 gggm(3)=gggm(3)+ees0mijp*zj &
14844                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14845
14846 ! Derivatives due to the contact function
14847                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14848                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14849                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14850                 do k=1,3
14851 !
14852 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14853 !          following the change of gradient-summation algorithm.
14854 !
14855 !grad                  ghalfp=0.5D0*gggp(k)
14856 !grad                  ghalfm=0.5D0*gggm(k)
14857 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14858 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14859 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14860 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14861 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14862 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14863 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14864 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14865 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14866 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14867 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14868 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14869 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14870 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14871                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14872                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14873                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14874                      *sss_ele_cut
14875
14876                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14877                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14878                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14879                      *sss_ele_cut
14880
14881                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14882                      *sss_ele_cut
14883
14884                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14885                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14886                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14887                      *sss_ele_cut
14888
14889                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14890                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14891                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14892                      *sss_ele_cut
14893
14894                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14895                      *sss_ele_cut
14896
14897                 enddo
14898               ENDIF ! wcorr
14899               endif  ! num_conti.le.maxconts
14900             endif  ! fcont.gt.0
14901           endif    ! j.gt.i+1
14902           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14903             do k=1,4
14904               do l=1,3
14905                 ghalf=0.5d0*agg(l,k)
14906                 aggi(l,k)=aggi(l,k)+ghalf
14907                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14908                 aggj(l,k)=aggj(l,k)+ghalf
14909               enddo
14910             enddo
14911             if (j.eq.nres-1 .and. i.lt.j-2) then
14912               do k=1,4
14913                 do l=1,3
14914                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14915                 enddo
14916               enddo
14917             endif
14918           endif
14919  128      continue
14920 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14921       return
14922       end subroutine eelecij_scale
14923 !-----------------------------------------------------------------------------
14924       subroutine evdwpp_short(evdw1)
14925 !
14926 ! Compute Evdwpp
14927 !
14928 !      implicit real*8 (a-h,o-z)
14929 !      include 'DIMENSIONS'
14930 !      include 'COMMON.CONTROL'
14931 !      include 'COMMON.IOUNITS'
14932 !      include 'COMMON.GEO'
14933 !      include 'COMMON.VAR'
14934 !      include 'COMMON.LOCAL'
14935 !      include 'COMMON.CHAIN'
14936 !      include 'COMMON.DERIV'
14937 !      include 'COMMON.INTERACT'
14938 !      include 'COMMON.CONTACTS'
14939 !      include 'COMMON.TORSION'
14940 !      include 'COMMON.VECTORS'
14941 !      include 'COMMON.FFIELD'
14942       real(kind=8),dimension(3) :: ggg
14943 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14944 #ifdef MOMENT
14945       real(kind=8) :: scal_el=1.0d0
14946 #else
14947       real(kind=8) :: scal_el=0.5d0
14948 #endif
14949 !el local variables
14950       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14951       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14952       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14953                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14954                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14955       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14956                     dist_temp, dist_init,sss_grad
14957       integer xshift,yshift,zshift
14958
14959
14960       evdw1=0.0D0
14961 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14962 !     & " iatel_e_vdw",iatel_e_vdw
14963       call flush(iout)
14964       do i=iatel_s_vdw,iatel_e_vdw
14965         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
14966         dxi=dc(1,i)
14967         dyi=dc(2,i)
14968         dzi=dc(3,i)
14969         dx_normi=dc_norm(1,i)
14970         dy_normi=dc_norm(2,i)
14971         dz_normi=dc_norm(3,i)
14972         xmedi=c(1,i)+0.5d0*dxi
14973         ymedi=c(2,i)+0.5d0*dyi
14974         zmedi=c(3,i)+0.5d0*dzi
14975           xmedi=dmod(xmedi,boxxsize)
14976           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14977           ymedi=dmod(ymedi,boxysize)
14978           if (ymedi.lt.0) ymedi=ymedi+boxysize
14979           zmedi=dmod(zmedi,boxzsize)
14980           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14981         num_conti=0
14982 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
14983 !     &   ' ielend',ielend_vdw(i)
14984         call flush(iout)
14985         do j=ielstart_vdw(i),ielend_vdw(i)
14986           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14987 !el          ind=ind+1
14988           iteli=itel(i)
14989           itelj=itel(j)
14990           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14991           aaa=app(iteli,itelj)
14992           bbb=bpp(iteli,itelj)
14993           dxj=dc(1,j)
14994           dyj=dc(2,j)
14995           dzj=dc(3,j)
14996           dx_normj=dc_norm(1,j)
14997           dy_normj=dc_norm(2,j)
14998           dz_normj=dc_norm(3,j)
14999 !          xj=c(1,j)+0.5D0*dxj-xmedi
15000 !          yj=c(2,j)+0.5D0*dyj-ymedi
15001 !          zj=c(3,j)+0.5D0*dzj-zmedi
15002           xj=c(1,j)+0.5D0*dxj
15003           yj=c(2,j)+0.5D0*dyj
15004           zj=c(3,j)+0.5D0*dzj
15005           xj=mod(xj,boxxsize)
15006           if (xj.lt.0) xj=xj+boxxsize
15007           yj=mod(yj,boxysize)
15008           if (yj.lt.0) yj=yj+boxysize
15009           zj=mod(zj,boxzsize)
15010           if (zj.lt.0) zj=zj+boxzsize
15011       isubchap=0
15012       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15013       xj_safe=xj
15014       yj_safe=yj
15015       zj_safe=zj
15016       do xshift=-1,1
15017       do yshift=-1,1
15018       do zshift=-1,1
15019           xj=xj_safe+xshift*boxxsize
15020           yj=yj_safe+yshift*boxysize
15021           zj=zj_safe+zshift*boxzsize
15022           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15023           if(dist_temp.lt.dist_init) then
15024             dist_init=dist_temp
15025             xj_temp=xj
15026             yj_temp=yj
15027             zj_temp=zj
15028             isubchap=1
15029           endif
15030        enddo
15031        enddo
15032        enddo
15033        if (isubchap.eq.1) then
15034 !C          print *,i,j
15035           xj=xj_temp-xmedi
15036           yj=yj_temp-ymedi
15037           zj=zj_temp-zmedi
15038        else
15039           xj=xj_safe-xmedi
15040           yj=yj_safe-ymedi
15041           zj=zj_safe-zmedi
15042        endif
15043
15044           rij=xj*xj+yj*yj+zj*zj
15045           rrmij=1.0D0/rij
15046           rij=dsqrt(rij)
15047           sss=sscale(rij/rpp(iteli,itelj))
15048             sss_ele_cut=sscale_ele(rij)
15049             sss_ele_grad=sscagrad_ele(rij)
15050             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15051             if (sss_ele_cut.le.0.0) cycle
15052           if (sss.gt.0.0d0) then
15053             rmij=1.0D0/rij
15054             r3ij=rrmij*rmij
15055             r6ij=r3ij*r3ij
15056             ev1=aaa*r6ij*r6ij
15057 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15058             if (j.eq.i+2) ev1=scal_el*ev1
15059             ev2=bbb*r6ij
15060             evdwij=ev1+ev2
15061             if (energy_dec) then
15062               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15063             endif
15064             evdw1=evdw1+evdwij*sss*sss_ele_cut
15065 !
15066 ! Calculate contributions to the Cartesian gradient.
15067 !
15068             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15069 !            ggg(1)=facvdw*xj
15070 !            ggg(2)=facvdw*yj
15071 !            ggg(3)=facvdw*zj
15072           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15073           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15074           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15075           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15076           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15077           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15078
15079             do k=1,3
15080               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15081               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15082             enddo
15083           endif
15084         enddo ! j
15085       enddo   ! i
15086       return
15087       end subroutine evdwpp_short
15088 !-----------------------------------------------------------------------------
15089       subroutine escp_long(evdw2,evdw2_14)
15090 !
15091 ! This subroutine calculates the excluded-volume interaction energy between
15092 ! peptide-group centers and side chains and its gradient in virtual-bond and
15093 ! side-chain vectors.
15094 !
15095 !      implicit real*8 (a-h,o-z)
15096 !      include 'DIMENSIONS'
15097 !      include 'COMMON.GEO'
15098 !      include 'COMMON.VAR'
15099 !      include 'COMMON.LOCAL'
15100 !      include 'COMMON.CHAIN'
15101 !      include 'COMMON.DERIV'
15102 !      include 'COMMON.INTERACT'
15103 !      include 'COMMON.FFIELD'
15104 !      include 'COMMON.IOUNITS'
15105 !      include 'COMMON.CONTROL'
15106       real(kind=8),dimension(3) :: ggg
15107 !el local variables
15108       integer :: i,iint,j,k,iteli,itypj,subchap
15109       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15110       real(kind=8) :: evdw2,evdw2_14,evdwij
15111       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15112                     dist_temp, dist_init
15113
15114       evdw2=0.0D0
15115       evdw2_14=0.0d0
15116 !d    print '(a)','Enter ESCP'
15117 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15118       do i=iatscp_s,iatscp_e
15119         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15120         iteli=itel(i)
15121         xi=0.5D0*(c(1,i)+c(1,i+1))
15122         yi=0.5D0*(c(2,i)+c(2,i+1))
15123         zi=0.5D0*(c(3,i)+c(3,i+1))
15124           xi=mod(xi,boxxsize)
15125           if (xi.lt.0) xi=xi+boxxsize
15126           yi=mod(yi,boxysize)
15127           if (yi.lt.0) yi=yi+boxysize
15128           zi=mod(zi,boxzsize)
15129           if (zi.lt.0) zi=zi+boxzsize
15130
15131         do iint=1,nscp_gr(i)
15132
15133         do j=iscpstart(i,iint),iscpend(i,iint)
15134           itypj=itype(j,1)
15135           if (itypj.eq.ntyp1) cycle
15136 ! Uncomment following three lines for SC-p interactions
15137 !         xj=c(1,nres+j)-xi
15138 !         yj=c(2,nres+j)-yi
15139 !         zj=c(3,nres+j)-zi
15140 ! Uncomment following three lines for Ca-p interactions
15141           xj=c(1,j)
15142           yj=c(2,j)
15143           zj=c(3,j)
15144           xj=mod(xj,boxxsize)
15145           if (xj.lt.0) xj=xj+boxxsize
15146           yj=mod(yj,boxysize)
15147           if (yj.lt.0) yj=yj+boxysize
15148           zj=mod(zj,boxzsize)
15149           if (zj.lt.0) zj=zj+boxzsize
15150       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15151       xj_safe=xj
15152       yj_safe=yj
15153       zj_safe=zj
15154       subchap=0
15155       do xshift=-1,1
15156       do yshift=-1,1
15157       do zshift=-1,1
15158           xj=xj_safe+xshift*boxxsize
15159           yj=yj_safe+yshift*boxysize
15160           zj=zj_safe+zshift*boxzsize
15161           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15162           if(dist_temp.lt.dist_init) then
15163             dist_init=dist_temp
15164             xj_temp=xj
15165             yj_temp=yj
15166             zj_temp=zj
15167             subchap=1
15168           endif
15169        enddo
15170        enddo
15171        enddo
15172        if (subchap.eq.1) then
15173           xj=xj_temp-xi
15174           yj=yj_temp-yi
15175           zj=zj_temp-zi
15176        else
15177           xj=xj_safe-xi
15178           yj=yj_safe-yi
15179           zj=zj_safe-zi
15180        endif
15181           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15182
15183           rij=dsqrt(1.0d0/rrij)
15184             sss_ele_cut=sscale_ele(rij)
15185             sss_ele_grad=sscagrad_ele(rij)
15186 !            print *,sss_ele_cut,sss_ele_grad,&
15187 !            (rij),r_cut_ele,rlamb_ele
15188             if (sss_ele_cut.le.0.0) cycle
15189           sss=sscale((rij/rscp(itypj,iteli)))
15190           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15191           if (sss.lt.1.0d0) then
15192
15193             fac=rrij**expon2
15194             e1=fac*fac*aad(itypj,iteli)
15195             e2=fac*bad(itypj,iteli)
15196             if (iabs(j-i) .le. 2) then
15197               e1=scal14*e1
15198               e2=scal14*e2
15199               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15200             endif
15201             evdwij=e1+e2
15202             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15203             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15204                 'evdw2',i,j,sss,evdwij
15205 !
15206 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15207 !
15208             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15209             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15210             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15211             ggg(1)=xj*fac
15212             ggg(2)=yj*fac
15213             ggg(3)=zj*fac
15214 ! Uncomment following three lines for SC-p interactions
15215 !           do k=1,3
15216 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15217 !           enddo
15218 ! Uncomment following line for SC-p interactions
15219 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15220             do k=1,3
15221               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15222               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15223             enddo
15224           endif
15225         enddo
15226
15227         enddo ! iint
15228       enddo ! i
15229       do i=1,nct
15230         do j=1,3
15231           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15232           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15233           gradx_scp(j,i)=expon*gradx_scp(j,i)
15234         enddo
15235       enddo
15236 !******************************************************************************
15237 !
15238 !                              N O T E !!!
15239 !
15240 ! To save time the factor EXPON has been extracted from ALL components
15241 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15242 ! use!
15243 !
15244 !******************************************************************************
15245       return
15246       end subroutine escp_long
15247 !-----------------------------------------------------------------------------
15248       subroutine escp_short(evdw2,evdw2_14)
15249 !
15250 ! This subroutine calculates the excluded-volume interaction energy between
15251 ! peptide-group centers and side chains and its gradient in virtual-bond and
15252 ! side-chain vectors.
15253 !
15254 !      implicit real*8 (a-h,o-z)
15255 !      include 'DIMENSIONS'
15256 !      include 'COMMON.GEO'
15257 !      include 'COMMON.VAR'
15258 !      include 'COMMON.LOCAL'
15259 !      include 'COMMON.CHAIN'
15260 !      include 'COMMON.DERIV'
15261 !      include 'COMMON.INTERACT'
15262 !      include 'COMMON.FFIELD'
15263 !      include 'COMMON.IOUNITS'
15264 !      include 'COMMON.CONTROL'
15265       real(kind=8),dimension(3) :: ggg
15266 !el local variables
15267       integer :: i,iint,j,k,iteli,itypj,subchap
15268       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15269       real(kind=8) :: evdw2,evdw2_14,evdwij
15270       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15271                     dist_temp, dist_init
15272
15273       evdw2=0.0D0
15274       evdw2_14=0.0d0
15275 !d    print '(a)','Enter ESCP'
15276 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15277       do i=iatscp_s,iatscp_e
15278         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15279         iteli=itel(i)
15280         xi=0.5D0*(c(1,i)+c(1,i+1))
15281         yi=0.5D0*(c(2,i)+c(2,i+1))
15282         zi=0.5D0*(c(3,i)+c(3,i+1))
15283           xi=mod(xi,boxxsize)
15284           if (xi.lt.0) xi=xi+boxxsize
15285           yi=mod(yi,boxysize)
15286           if (yi.lt.0) yi=yi+boxysize
15287           zi=mod(zi,boxzsize)
15288           if (zi.lt.0) zi=zi+boxzsize
15289
15290         do iint=1,nscp_gr(i)
15291
15292         do j=iscpstart(i,iint),iscpend(i,iint)
15293           itypj=itype(j,1)
15294           if (itypj.eq.ntyp1) cycle
15295 ! Uncomment following three lines for SC-p interactions
15296 !         xj=c(1,nres+j)-xi
15297 !         yj=c(2,nres+j)-yi
15298 !         zj=c(3,nres+j)-zi
15299 ! Uncomment following three lines for Ca-p interactions
15300 !          xj=c(1,j)-xi
15301 !          yj=c(2,j)-yi
15302 !          zj=c(3,j)-zi
15303           xj=c(1,j)
15304           yj=c(2,j)
15305           zj=c(3,j)
15306           xj=mod(xj,boxxsize)
15307           if (xj.lt.0) xj=xj+boxxsize
15308           yj=mod(yj,boxysize)
15309           if (yj.lt.0) yj=yj+boxysize
15310           zj=mod(zj,boxzsize)
15311           if (zj.lt.0) zj=zj+boxzsize
15312       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15313       xj_safe=xj
15314       yj_safe=yj
15315       zj_safe=zj
15316       subchap=0
15317       do xshift=-1,1
15318       do yshift=-1,1
15319       do zshift=-1,1
15320           xj=xj_safe+xshift*boxxsize
15321           yj=yj_safe+yshift*boxysize
15322           zj=zj_safe+zshift*boxzsize
15323           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15324           if(dist_temp.lt.dist_init) then
15325             dist_init=dist_temp
15326             xj_temp=xj
15327             yj_temp=yj
15328             zj_temp=zj
15329             subchap=1
15330           endif
15331        enddo
15332        enddo
15333        enddo
15334        if (subchap.eq.1) then
15335           xj=xj_temp-xi
15336           yj=yj_temp-yi
15337           zj=zj_temp-zi
15338        else
15339           xj=xj_safe-xi
15340           yj=yj_safe-yi
15341           zj=zj_safe-zi
15342        endif
15343
15344           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15345           rij=dsqrt(1.0d0/rrij)
15346             sss_ele_cut=sscale_ele(rij)
15347             sss_ele_grad=sscagrad_ele(rij)
15348 !            print *,sss_ele_cut,sss_ele_grad,&
15349 !            (rij),r_cut_ele,rlamb_ele
15350             if (sss_ele_cut.le.0.0) cycle
15351           sss=sscale(rij/rscp(itypj,iteli))
15352           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15353           if (sss.gt.0.0d0) then
15354
15355             fac=rrij**expon2
15356             e1=fac*fac*aad(itypj,iteli)
15357             e2=fac*bad(itypj,iteli)
15358             if (iabs(j-i) .le. 2) then
15359               e1=scal14*e1
15360               e2=scal14*e2
15361               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15362             endif
15363             evdwij=e1+e2
15364             evdw2=evdw2+evdwij*sss*sss_ele_cut
15365             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15366                 'evdw2',i,j,sss,evdwij
15367 !
15368 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15369 !
15370             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15371             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15372             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15373
15374             ggg(1)=xj*fac
15375             ggg(2)=yj*fac
15376             ggg(3)=zj*fac
15377 ! Uncomment following three lines for SC-p interactions
15378 !           do k=1,3
15379 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15380 !           enddo
15381 ! Uncomment following line for SC-p interactions
15382 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15383             do k=1,3
15384               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15385               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15386             enddo
15387           endif
15388         enddo
15389
15390         enddo ! iint
15391       enddo ! i
15392       do i=1,nct
15393         do j=1,3
15394           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15395           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15396           gradx_scp(j,i)=expon*gradx_scp(j,i)
15397         enddo
15398       enddo
15399 !******************************************************************************
15400 !
15401 !                              N O T E !!!
15402 !
15403 ! To save time the factor EXPON has been extracted from ALL components
15404 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15405 ! use!
15406 !
15407 !******************************************************************************
15408       return
15409       end subroutine escp_short
15410 !-----------------------------------------------------------------------------
15411 ! energy_p_new-sep_barrier.F
15412 !-----------------------------------------------------------------------------
15413       subroutine sc_grad_scale(scalfac)
15414 !      implicit real*8 (a-h,o-z)
15415       use calc_data
15416 !      include 'DIMENSIONS'
15417 !      include 'COMMON.CHAIN'
15418 !      include 'COMMON.DERIV'
15419 !      include 'COMMON.CALC'
15420 !      include 'COMMON.IOUNITS'
15421       real(kind=8),dimension(3) :: dcosom1,dcosom2
15422       real(kind=8) :: scalfac
15423 !el local variables
15424 !      integer :: i,j,k,l
15425
15426       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15427       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15428       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15429            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15430 ! diagnostics only
15431 !      eom1=0.0d0
15432 !      eom2=0.0d0
15433 !      eom12=evdwij*eps1_om12
15434 ! end diagnostics
15435 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15436 !     &  " sigder",sigder
15437 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15438 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15439       do k=1,3
15440         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15441         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15442       enddo
15443       do k=1,3
15444         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15445          *sss_ele_cut
15446       enddo
15447 !      write (iout,*) "gg",(gg(k),k=1,3)
15448       do k=1,3
15449         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15450                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15451                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15452                  *sss_ele_cut
15453         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15454                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15455                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15456          *sss_ele_cut
15457 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15458 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15459 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15460 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15461       enddo
15462 !
15463 ! Calculate the components of the gradient in DC and X
15464 !
15465       do l=1,3
15466         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15467         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15468       enddo
15469       return
15470       end subroutine sc_grad_scale
15471 !-----------------------------------------------------------------------------
15472 ! energy_split-sep.F
15473 !-----------------------------------------------------------------------------
15474       subroutine etotal_long(energia)
15475 !
15476 ! Compute the long-range slow-varying contributions to the energy
15477 !
15478 !      implicit real*8 (a-h,o-z)
15479 !      include 'DIMENSIONS'
15480       use MD_data, only: totT,usampl,eq_time
15481 #ifndef ISNAN
15482       external proc_proc
15483 #ifdef WINPGI
15484 !MS$ATTRIBUTES C ::  proc_proc
15485 #endif
15486 #endif
15487 #ifdef MPI
15488       include "mpif.h"
15489       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15490 #endif
15491 !      include 'COMMON.SETUP'
15492 !      include 'COMMON.IOUNITS'
15493 !      include 'COMMON.FFIELD'
15494 !      include 'COMMON.DERIV'
15495 !      include 'COMMON.INTERACT'
15496 !      include 'COMMON.SBRIDGE'
15497 !      include 'COMMON.CHAIN'
15498 !      include 'COMMON.VAR'
15499 !      include 'COMMON.LOCAL'
15500 !      include 'COMMON.MD'
15501       real(kind=8),dimension(0:n_ene) :: energia
15502 !el local variables
15503       integer :: i,n_corr,n_corr1,ierror,ierr
15504       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15505                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15506                   ecorr,ecorr5,ecorr6,eturn6,time00
15507 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15508 !elwrite(iout,*)"in etotal long"
15509
15510       if (modecalc.eq.12.or.modecalc.eq.14) then
15511 #ifdef MPI
15512 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15513 #else
15514         call int_from_cart1(.false.)
15515 #endif
15516       endif
15517 !elwrite(iout,*)"in etotal long"
15518
15519 #ifdef MPI
15520 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15521 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15522       call flush(iout)
15523       if (nfgtasks.gt.1) then
15524         time00=MPI_Wtime()
15525 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15526         if (fg_rank.eq.0) then
15527           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15528 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15529 !          call flush(iout)
15530 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15531 ! FG slaves as WEIGHTS array.
15532           weights_(1)=wsc
15533           weights_(2)=wscp
15534           weights_(3)=welec
15535           weights_(4)=wcorr
15536           weights_(5)=wcorr5
15537           weights_(6)=wcorr6
15538           weights_(7)=wel_loc
15539           weights_(8)=wturn3
15540           weights_(9)=wturn4
15541           weights_(10)=wturn6
15542           weights_(11)=wang
15543           weights_(12)=wscloc
15544           weights_(13)=wtor
15545           weights_(14)=wtor_d
15546           weights_(15)=wstrain
15547           weights_(16)=wvdwpp
15548           weights_(17)=wbond
15549           weights_(18)=scal14
15550           weights_(21)=wsccor
15551 ! FG Master broadcasts the WEIGHTS_ array
15552           call MPI_Bcast(weights_(1),n_ene,&
15553               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15554         else
15555 ! FG slaves receive the WEIGHTS array
15556           call MPI_Bcast(weights(1),n_ene,&
15557               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15558           wsc=weights(1)
15559           wscp=weights(2)
15560           welec=weights(3)
15561           wcorr=weights(4)
15562           wcorr5=weights(5)
15563           wcorr6=weights(6)
15564           wel_loc=weights(7)
15565           wturn3=weights(8)
15566           wturn4=weights(9)
15567           wturn6=weights(10)
15568           wang=weights(11)
15569           wscloc=weights(12)
15570           wtor=weights(13)
15571           wtor_d=weights(14)
15572           wstrain=weights(15)
15573           wvdwpp=weights(16)
15574           wbond=weights(17)
15575           scal14=weights(18)
15576           wsccor=weights(21)
15577         endif
15578         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15579           king,FG_COMM,IERR)
15580          time_Bcast=time_Bcast+MPI_Wtime()-time00
15581          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15582 !        call chainbuild_cart
15583 !        call int_from_cart1(.false.)
15584       endif
15585 !      write (iout,*) 'Processor',myrank,
15586 !     &  ' calling etotal_short ipot=',ipot
15587 !      call flush(iout)
15588 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15589 #endif
15590 !d    print *,'nnt=',nnt,' nct=',nct
15591 !
15592 !elwrite(iout,*)"in etotal long"
15593 ! Compute the side-chain and electrostatic interaction energy
15594 !
15595       goto (101,102,103,104,105,106) ipot
15596 ! Lennard-Jones potential.
15597   101 call elj_long(evdw)
15598 !d    print '(a)','Exit ELJ'
15599       goto 107
15600 ! Lennard-Jones-Kihara potential (shifted).
15601   102 call eljk_long(evdw)
15602       goto 107
15603 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15604   103 call ebp_long(evdw)
15605       goto 107
15606 ! Gay-Berne potential (shifted LJ, angular dependence).
15607   104 call egb_long(evdw)
15608       goto 107
15609 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15610   105 call egbv_long(evdw)
15611       goto 107
15612 ! Soft-sphere potential
15613   106 call e_softsphere(evdw)
15614 !
15615 ! Calculate electrostatic (H-bonding) energy of the main chain.
15616 !
15617   107 continue
15618       call vec_and_deriv
15619       if (ipot.lt.6) then
15620 #ifdef SPLITELE
15621          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15622              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15623              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15624              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15625 #else
15626          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15627              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15628              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15629              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15630 #endif
15631            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15632          else
15633             ees=0
15634             evdw1=0
15635             eel_loc=0
15636             eello_turn3=0
15637             eello_turn4=0
15638          endif
15639       else
15640 !        write (iout,*) "Soft-spheer ELEC potential"
15641         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15642          eello_turn4)
15643       endif
15644 !
15645 ! Calculate excluded-volume interaction energy between peptide groups
15646 ! and side chains.
15647 !
15648       if (ipot.lt.6) then
15649        if(wscp.gt.0d0) then
15650         call escp_long(evdw2,evdw2_14)
15651        else
15652         evdw2=0
15653         evdw2_14=0
15654        endif
15655       else
15656         call escp_soft_sphere(evdw2,evdw2_14)
15657       endif
15658 !
15659 ! 12/1/95 Multi-body terms
15660 !
15661       n_corr=0
15662       n_corr1=0
15663       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15664           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15665          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15666 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15667 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15668       else
15669          ecorr=0.0d0
15670          ecorr5=0.0d0
15671          ecorr6=0.0d0
15672          eturn6=0.0d0
15673       endif
15674       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15675          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15676       endif
15677 !
15678 ! If performing constraint dynamics, call the constraint energy
15679 !  after the equilibration time
15680       if(usampl.and.totT.gt.eq_time) then
15681          call EconstrQ
15682          call Econstr_back
15683       else
15684          Uconst=0.0d0
15685          Uconst_back=0.0d0
15686       endif
15687 !
15688 ! Sum the energies
15689 !
15690       do i=1,n_ene
15691         energia(i)=0.0d0
15692       enddo
15693       energia(1)=evdw
15694 #ifdef SCP14
15695       energia(2)=evdw2-evdw2_14
15696       energia(18)=evdw2_14
15697 #else
15698       energia(2)=evdw2
15699       energia(18)=0.0d0
15700 #endif
15701 #ifdef SPLITELE
15702       energia(3)=ees
15703       energia(16)=evdw1
15704 #else
15705       energia(3)=ees+evdw1
15706       energia(16)=0.0d0
15707 #endif
15708       energia(4)=ecorr
15709       energia(5)=ecorr5
15710       energia(6)=ecorr6
15711       energia(7)=eel_loc
15712       energia(8)=eello_turn3
15713       energia(9)=eello_turn4
15714       energia(10)=eturn6
15715       energia(20)=Uconst+Uconst_back
15716       call sum_energy(energia,.true.)
15717 !      write (iout,*) "Exit ETOTAL_LONG"
15718       call flush(iout)
15719       return
15720       end subroutine etotal_long
15721 !-----------------------------------------------------------------------------
15722       subroutine etotal_short(energia)
15723 !
15724 ! Compute the short-range fast-varying contributions to the energy
15725 !
15726 !      implicit real*8 (a-h,o-z)
15727 !      include 'DIMENSIONS'
15728 #ifndef ISNAN
15729       external proc_proc
15730 #ifdef WINPGI
15731 !MS$ATTRIBUTES C ::  proc_proc
15732 #endif
15733 #endif
15734 #ifdef MPI
15735       include "mpif.h"
15736       integer :: ierror,ierr
15737       real(kind=8),dimension(n_ene) :: weights_
15738       real(kind=8) :: time00
15739 #endif
15740 !      include 'COMMON.SETUP'
15741 !      include 'COMMON.IOUNITS'
15742 !      include 'COMMON.FFIELD'
15743 !      include 'COMMON.DERIV'
15744 !      include 'COMMON.INTERACT'
15745 !      include 'COMMON.SBRIDGE'
15746 !      include 'COMMON.CHAIN'
15747 !      include 'COMMON.VAR'
15748 !      include 'COMMON.LOCAL'
15749       real(kind=8),dimension(0:n_ene) :: energia
15750 !el local variables
15751       integer :: i,nres6
15752       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15753       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15754       nres6=6*nres
15755
15756 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15757 !      call flush(iout)
15758       if (modecalc.eq.12.or.modecalc.eq.14) then
15759 #ifdef MPI
15760         if (fg_rank.eq.0) call int_from_cart1(.false.)
15761 #else
15762         call int_from_cart1(.false.)
15763 #endif
15764       endif
15765 #ifdef MPI
15766 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15767 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15768 !      call flush(iout)
15769       if (nfgtasks.gt.1) then
15770         time00=MPI_Wtime()
15771 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15772         if (fg_rank.eq.0) then
15773           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15774 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15775 !          call flush(iout)
15776 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15777 ! FG slaves as WEIGHTS array.
15778           weights_(1)=wsc
15779           weights_(2)=wscp
15780           weights_(3)=welec
15781           weights_(4)=wcorr
15782           weights_(5)=wcorr5
15783           weights_(6)=wcorr6
15784           weights_(7)=wel_loc
15785           weights_(8)=wturn3
15786           weights_(9)=wturn4
15787           weights_(10)=wturn6
15788           weights_(11)=wang
15789           weights_(12)=wscloc
15790           weights_(13)=wtor
15791           weights_(14)=wtor_d
15792           weights_(15)=wstrain
15793           weights_(16)=wvdwpp
15794           weights_(17)=wbond
15795           weights_(18)=scal14
15796           weights_(21)=wsccor
15797 ! FG Master broadcasts the WEIGHTS_ array
15798           call MPI_Bcast(weights_(1),n_ene,&
15799               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15800         else
15801 ! FG slaves receive the WEIGHTS array
15802           call MPI_Bcast(weights(1),n_ene,&
15803               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15804           wsc=weights(1)
15805           wscp=weights(2)
15806           welec=weights(3)
15807           wcorr=weights(4)
15808           wcorr5=weights(5)
15809           wcorr6=weights(6)
15810           wel_loc=weights(7)
15811           wturn3=weights(8)
15812           wturn4=weights(9)
15813           wturn6=weights(10)
15814           wang=weights(11)
15815           wscloc=weights(12)
15816           wtor=weights(13)
15817           wtor_d=weights(14)
15818           wstrain=weights(15)
15819           wvdwpp=weights(16)
15820           wbond=weights(17)
15821           scal14=weights(18)
15822           wsccor=weights(21)
15823         endif
15824 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15825         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15826           king,FG_COMM,IERR)
15827 !        write (iout,*) "Processor",myrank," BROADCAST c"
15828         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15829           king,FG_COMM,IERR)
15830 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15831         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15832           king,FG_COMM,IERR)
15833 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15834         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15835           king,FG_COMM,IERR)
15836 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15837         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15838           king,FG_COMM,IERR)
15839 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15840         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15841           king,FG_COMM,IERR)
15842 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15843         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15844           king,FG_COMM,IERR)
15845 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15846         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15847           king,FG_COMM,IERR)
15848 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15849         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15850           king,FG_COMM,IERR)
15851          time_Bcast=time_Bcast+MPI_Wtime()-time00
15852 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15853       endif
15854 !      write (iout,*) 'Processor',myrank,
15855 !     &  ' calling etotal_short ipot=',ipot
15856 !      call flush(iout)
15857 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15858 #endif
15859 !      call int_from_cart1(.false.)
15860 !
15861 ! Compute the side-chain and electrostatic interaction energy
15862 !
15863       goto (101,102,103,104,105,106) ipot
15864 ! Lennard-Jones potential.
15865   101 call elj_short(evdw)
15866 !d    print '(a)','Exit ELJ'
15867       goto 107
15868 ! Lennard-Jones-Kihara potential (shifted).
15869   102 call eljk_short(evdw)
15870       goto 107
15871 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15872   103 call ebp_short(evdw)
15873       goto 107
15874 ! Gay-Berne potential (shifted LJ, angular dependence).
15875   104 call egb_short(evdw)
15876       goto 107
15877 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15878   105 call egbv_short(evdw)
15879       goto 107
15880 ! Soft-sphere potential - already dealt with in the long-range part
15881   106 evdw=0.0d0
15882 !  106 call e_softsphere_short(evdw)
15883 !
15884 ! Calculate electrostatic (H-bonding) energy of the main chain.
15885 !
15886   107 continue
15887 !
15888 ! Calculate the short-range part of Evdwpp
15889 !
15890       call evdwpp_short(evdw1)
15891 !
15892 ! Calculate the short-range part of ESCp
15893 !
15894       if (ipot.lt.6) then
15895         call escp_short(evdw2,evdw2_14)
15896       endif
15897 !
15898 ! Calculate the bond-stretching energy
15899 !
15900       call ebond(estr)
15901 !
15902 ! Calculate the disulfide-bridge and other energy and the contributions
15903 ! from other distance constraints.
15904       call edis(ehpb)
15905 !
15906 ! Calculate the virtual-bond-angle energy.
15907 !
15908       call ebend(ebe,ethetacnstr)
15909 !
15910 ! Calculate the SC local energy.
15911 !
15912       call vec_and_deriv
15913       call esc(escloc)
15914 !
15915 ! Calculate the virtual-bond torsional energy.
15916 !
15917       call etor(etors,edihcnstr)
15918 !
15919 ! 6/23/01 Calculate double-torsional energy
15920 !
15921       call etor_d(etors_d)
15922 !
15923 ! 21/5/07 Calculate local sicdechain correlation energy
15924 !
15925       if (wsccor.gt.0.0d0) then
15926         call eback_sc_corr(esccor)
15927       else
15928         esccor=0.0d0
15929       endif
15930 !
15931 ! Put energy components into an array
15932 !
15933       do i=1,n_ene
15934         energia(i)=0.0d0
15935       enddo
15936       energia(1)=evdw
15937 #ifdef SCP14
15938       energia(2)=evdw2-evdw2_14
15939       energia(18)=evdw2_14
15940 #else
15941       energia(2)=evdw2
15942       energia(18)=0.0d0
15943 #endif
15944 #ifdef SPLITELE
15945       energia(16)=evdw1
15946 #else
15947       energia(3)=evdw1
15948 #endif
15949       energia(11)=ebe
15950       energia(12)=escloc
15951       energia(13)=etors
15952       energia(14)=etors_d
15953       energia(15)=ehpb
15954       energia(17)=estr
15955       energia(19)=edihcnstr
15956       energia(21)=esccor
15957 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15958       call flush(iout)
15959       call sum_energy(energia,.true.)
15960 !      write (iout,*) "Exit ETOTAL_SHORT"
15961       call flush(iout)
15962       return
15963       end subroutine etotal_short
15964 !-----------------------------------------------------------------------------
15965 ! gnmr1.f
15966 !-----------------------------------------------------------------------------
15967       real(kind=8) function gnmr1(y,ymin,ymax)
15968 !      implicit none
15969       real(kind=8) :: y,ymin,ymax
15970       real(kind=8) :: wykl=4.0d0
15971       if (y.lt.ymin) then
15972         gnmr1=(ymin-y)**wykl/wykl
15973       else if (y.gt.ymax) then
15974         gnmr1=(y-ymax)**wykl/wykl
15975       else
15976         gnmr1=0.0d0
15977       endif
15978       return
15979       end function gnmr1
15980 !-----------------------------------------------------------------------------
15981       real(kind=8) function gnmr1prim(y,ymin,ymax)
15982 !      implicit none
15983       real(kind=8) :: y,ymin,ymax
15984       real(kind=8) :: wykl=4.0d0
15985       if (y.lt.ymin) then
15986         gnmr1prim=-(ymin-y)**(wykl-1)
15987       else if (y.gt.ymax) then
15988         gnmr1prim=(y-ymax)**(wykl-1)
15989       else
15990         gnmr1prim=0.0d0
15991       endif
15992       return
15993       end function gnmr1prim
15994 !----------------------------------------------------------------------------
15995       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
15996       real(kind=8) y,ymin,ymax,sigma
15997       real(kind=8) wykl /4.0d0/
15998       if (y.lt.ymin) then
15999         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16000       else if (y.gt.ymax) then
16001         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16002       else
16003         rlornmr1=0.0d0
16004       endif
16005       return
16006       end function rlornmr1
16007 !------------------------------------------------------------------------------
16008       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16009       real(kind=8) y,ymin,ymax,sigma
16010       real(kind=8) wykl /4.0d0/
16011       if (y.lt.ymin) then
16012         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16013         ((ymin-y)**wykl+sigma**wykl)**2
16014       else if (y.gt.ymax) then
16015         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16016         ((y-ymax)**wykl+sigma**wykl)**2
16017       else
16018         rlornmr1prim=0.0d0
16019       endif
16020       return
16021       end function rlornmr1prim
16022
16023       real(kind=8) function harmonic(y,ymax)
16024 !      implicit none
16025       real(kind=8) :: y,ymax
16026       real(kind=8) :: wykl=2.0d0
16027       harmonic=(y-ymax)**wykl
16028       return
16029       end function harmonic
16030 !-----------------------------------------------------------------------------
16031       real(kind=8) function harmonicprim(y,ymax)
16032       real(kind=8) :: y,ymin,ymax
16033       real(kind=8) :: wykl=2.0d0
16034       harmonicprim=(y-ymax)*wykl
16035       return
16036       end function harmonicprim
16037 !-----------------------------------------------------------------------------
16038 ! gradient_p.F
16039 !-----------------------------------------------------------------------------
16040       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16041
16042       use io_base, only:intout,briefout
16043 !      implicit real*8 (a-h,o-z)
16044 !      include 'DIMENSIONS'
16045 !      include 'COMMON.CHAIN'
16046 !      include 'COMMON.DERIV'
16047 !      include 'COMMON.VAR'
16048 !      include 'COMMON.INTERACT'
16049 !      include 'COMMON.FFIELD'
16050 !      include 'COMMON.MD'
16051 !      include 'COMMON.IOUNITS'
16052       real(kind=8),external :: ufparm
16053       integer :: uiparm(1)
16054       real(kind=8) :: urparm(1)
16055       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16056       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16057       integer :: n,nf,ind,ind1,i,k,j
16058 !
16059 ! This subroutine calculates total internal coordinate gradient.
16060 ! Depending on the number of function evaluations, either whole energy
16061 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16062 ! internal coordinates are reevaluated or only the cartesian-in-internal
16063 ! coordinate derivatives are evaluated. The subroutine was designed to work
16064 ! with SUMSL.
16065 !
16066 !
16067       icg=mod(nf,2)+1
16068
16069 !d      print *,'grad',nf,icg
16070       if (nf-nfl+1) 20,30,40
16071    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16072 !    write (iout,*) 'grad 20'
16073       if (nf.eq.0) return
16074       goto 40
16075    30 call var_to_geom(n,x)
16076       call chainbuild
16077 !    write (iout,*) 'grad 30'
16078 !
16079 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16080 !
16081    40 call cartder
16082 !     write (iout,*) 'grad 40'
16083 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16084 !
16085 ! Convert the Cartesian gradient into internal-coordinate gradient.
16086 !
16087       ind=0
16088       ind1=0
16089       do i=1,nres-2
16090       gthetai=0.0D0
16091       gphii=0.0D0
16092       do j=i+1,nres-1
16093           ind=ind+1
16094 !         ind=indmat(i,j)
16095 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16096         do k=1,3
16097             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16098           enddo
16099         do k=1,3
16100           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16101           enddo
16102         enddo
16103       do j=i+1,nres-1
16104           ind1=ind1+1
16105 !         ind1=indmat(i,j)
16106 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16107         do k=1,3
16108           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16109           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16110           enddo
16111         enddo
16112       if (i.gt.1) g(i-1)=gphii
16113       if (n.gt.nphi) g(nphi+i)=gthetai
16114       enddo
16115       if (n.le.nphi+ntheta) goto 10
16116       do i=2,nres-1
16117       if (itype(i,1).ne.10) then
16118           galphai=0.0D0
16119         gomegai=0.0D0
16120         do k=1,3
16121           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16122           enddo
16123         do k=1,3
16124           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16125           enddo
16126           g(ialph(i,1))=galphai
16127         g(ialph(i,1)+nside)=gomegai
16128         endif
16129       enddo
16130 !
16131 ! Add the components corresponding to local energy terms.
16132 !
16133    10 continue
16134       do i=1,nvar
16135 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16136         g(i)=g(i)+gloc(i,icg)
16137       enddo
16138 ! Uncomment following three lines for diagnostics.
16139 !d    call intout
16140 !elwrite(iout,*) "in gradient after calling intout"
16141 !d    call briefout(0,0.0d0)
16142 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16143       return
16144       end subroutine gradient
16145 !-----------------------------------------------------------------------------
16146       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16147
16148       use comm_chu
16149 !      implicit real*8 (a-h,o-z)
16150 !      include 'DIMENSIONS'
16151 !      include 'COMMON.DERIV'
16152 !      include 'COMMON.IOUNITS'
16153 !      include 'COMMON.GEO'
16154       integer :: n,nf
16155 !el      integer :: jjj
16156 !el      common /chuju/ jjj
16157       real(kind=8) :: energia(0:n_ene)
16158       integer :: uiparm(1)
16159       real(kind=8) :: urparm(1)
16160       real(kind=8) :: f
16161       real(kind=8),external :: ufparm
16162       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16163 !     if (jjj.gt.0) then
16164 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16165 !     endif
16166       nfl=nf
16167       icg=mod(nf,2)+1
16168 !d      print *,'func',nf,nfl,icg
16169       call var_to_geom(n,x)
16170       call zerograd
16171       call chainbuild
16172 !d    write (iout,*) 'ETOTAL called from FUNC'
16173       call etotal(energia)
16174       call sum_gradient
16175       f=energia(0)
16176 !     if (jjj.gt.0) then
16177 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16178 !       write (iout,*) 'f=',etot
16179 !       jjj=0
16180 !     endif
16181       return
16182       end subroutine func
16183 !-----------------------------------------------------------------------------
16184       subroutine cartgrad
16185 !      implicit real*8 (a-h,o-z)
16186 !      include 'DIMENSIONS'
16187       use energy_data
16188       use MD_data, only: totT,usampl,eq_time
16189 #ifdef MPI
16190       include 'mpif.h'
16191 #endif
16192 !      include 'COMMON.CHAIN'
16193 !      include 'COMMON.DERIV'
16194 !      include 'COMMON.VAR'
16195 !      include 'COMMON.INTERACT'
16196 !      include 'COMMON.FFIELD'
16197 !      include 'COMMON.MD'
16198 !      include 'COMMON.IOUNITS'
16199 !      include 'COMMON.TIME1'
16200 !
16201       integer :: i,j
16202
16203 ! This subrouting calculates total Cartesian coordinate gradient.
16204 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16205 !
16206 !el#define DEBUG
16207 #ifdef TIMING
16208       time00=MPI_Wtime()
16209 #endif
16210       icg=1
16211       call sum_gradient
16212 #ifdef TIMING
16213 #endif
16214 !el      write (iout,*) "After sum_gradient"
16215 #ifdef DEBUG
16216 !el      write (iout,*) "After sum_gradient"
16217       do i=1,nres-1
16218         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16219         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16220       enddo
16221 #endif
16222 ! If performing constraint dynamics, add the gradients of the constraint energy
16223       if(usampl.and.totT.gt.eq_time) then
16224          do i=1,nct
16225            do j=1,3
16226              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16227              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16228            enddo
16229          enddo
16230          do i=1,nres-3
16231            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16232          enddo
16233          do i=1,nres-2
16234            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16235          enddo
16236       endif
16237 !elwrite (iout,*) "After sum_gradient"
16238 #ifdef TIMING
16239       time01=MPI_Wtime()
16240 #endif
16241       call intcartderiv
16242 !elwrite (iout,*) "After sum_gradient"
16243 #ifdef TIMING
16244       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16245 #endif
16246 !     call checkintcartgrad
16247 !     write(iout,*) 'calling int_to_cart'
16248 #ifdef DEBUG
16249       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16250 #endif
16251       do i=0,nct
16252         do j=1,3
16253           gcart(j,i)=gradc(j,i,icg)
16254           gxcart(j,i)=gradx(j,i,icg)
16255 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16256         enddo
16257 #ifdef DEBUG
16258         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16259           (gxcart(j,i),j=1,3),gloc(i,icg)
16260 #endif
16261       enddo
16262 #ifdef TIMING
16263       time01=MPI_Wtime()
16264 #endif
16265 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16266       call int_to_cart
16267 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16268
16269 #ifdef TIMING
16270             time_inttocart=time_inttocart+MPI_Wtime()-time01
16271 #endif
16272 #ifdef DEBUG
16273             write (iout,*) "gcart and gxcart after int_to_cart"
16274             do i=0,nres-1
16275             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16276                 (gxcart(j,i),j=1,3)
16277             enddo
16278 #endif
16279 #ifdef CARGRAD
16280 #ifdef DEBUG
16281             write (iout,*) "CARGRAD"
16282 #endif
16283             do i=nres,0,-1
16284             do j=1,3
16285               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16286       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16287             enddo
16288       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16289       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16290             enddo
16291       ! Correction: dummy residues
16292             if (nnt.gt.1) then
16293               do j=1,3
16294       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16295                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16296               enddo
16297             endif
16298             if (nct.lt.nres) then
16299               do j=1,3
16300       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16301                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16302               enddo
16303             endif
16304 #endif
16305 #ifdef TIMING
16306             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16307 #endif
16308       !el#undef DEBUG
16309             return
16310             end subroutine cartgrad
16311       !-----------------------------------------------------------------------------
16312             subroutine zerograd
16313       !      implicit real*8 (a-h,o-z)
16314       !      include 'DIMENSIONS'
16315       !      include 'COMMON.DERIV'
16316       !      include 'COMMON.CHAIN'
16317       !      include 'COMMON.VAR'
16318       !      include 'COMMON.MD'
16319       !      include 'COMMON.SCCOR'
16320       !
16321       !el local variables
16322             integer :: i,j,intertyp,k
16323       ! Initialize Cartesian-coordinate gradient
16324       !
16325       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16326       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16327
16328       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16329       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16330       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16331       !      allocate(gradcorr_long(3,nres))
16332       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16333       !      allocate(gcorr6_turn_long(3,nres))
16334       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16335
16336       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16337
16338       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16339       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16340
16341       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16342       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16343
16344       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16345       !      allocate(gscloc(3,nres)) !(3,maxres)
16346       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16347
16348
16349
16350       !      common /deriv_scloc/
16351       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16352       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16353       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16354       !      common /mpgrad/
16355       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16356
16357
16358
16359       !          gradc(j,i,icg)=0.0d0
16360       !          gradx(j,i,icg)=0.0d0
16361
16362       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16363       !elwrite(iout,*) "icg",icg
16364             do i=-1,nres
16365             do j=1,3
16366               gvdwx(j,i)=0.0D0
16367               gradx_scp(j,i)=0.0D0
16368               gvdwc(j,i)=0.0D0
16369               gvdwc_scp(j,i)=0.0D0
16370               gvdwc_scpp(j,i)=0.0d0
16371               gelc(j,i)=0.0D0
16372               gelc_long(j,i)=0.0D0
16373               gradb(j,i)=0.0d0
16374               gradbx(j,i)=0.0d0
16375               gvdwpp(j,i)=0.0d0
16376               gel_loc(j,i)=0.0d0
16377               gel_loc_long(j,i)=0.0d0
16378               ghpbc(j,i)=0.0D0
16379               ghpbx(j,i)=0.0D0
16380               gcorr3_turn(j,i)=0.0d0
16381               gcorr4_turn(j,i)=0.0d0
16382               gradcorr(j,i)=0.0d0
16383               gradcorr_long(j,i)=0.0d0
16384               gradcorr5_long(j,i)=0.0d0
16385               gradcorr6_long(j,i)=0.0d0
16386               gcorr6_turn_long(j,i)=0.0d0
16387               gradcorr5(j,i)=0.0d0
16388               gradcorr6(j,i)=0.0d0
16389               gcorr6_turn(j,i)=0.0d0
16390               gsccorc(j,i)=0.0d0
16391               gsccorx(j,i)=0.0d0
16392               gradc(j,i,icg)=0.0d0
16393               gradx(j,i,icg)=0.0d0
16394               gscloc(j,i)=0.0d0
16395               gsclocx(j,i)=0.0d0
16396               gliptran(j,i)=0.0d0
16397               gliptranx(j,i)=0.0d0
16398               gliptranc(j,i)=0.0d0
16399               gshieldx(j,i)=0.0d0
16400               gshieldc(j,i)=0.0d0
16401               gshieldc_loc(j,i)=0.0d0
16402               gshieldx_ec(j,i)=0.0d0
16403               gshieldc_ec(j,i)=0.0d0
16404               gshieldc_loc_ec(j,i)=0.0d0
16405               gshieldx_t3(j,i)=0.0d0
16406               gshieldc_t3(j,i)=0.0d0
16407               gshieldc_loc_t3(j,i)=0.0d0
16408               gshieldx_t4(j,i)=0.0d0
16409               gshieldc_t4(j,i)=0.0d0
16410               gshieldc_loc_t4(j,i)=0.0d0
16411               gshieldx_ll(j,i)=0.0d0
16412               gshieldc_ll(j,i)=0.0d0
16413               gshieldc_loc_ll(j,i)=0.0d0
16414               gg_tube(j,i)=0.0d0
16415               gg_tube_sc(j,i)=0.0d0
16416               gradafm(j,i)=0.0d0
16417               gradb_nucl(j,i)=0.0d0
16418               gradbx_nucl(j,i)=0.0d0
16419               gvdwpp_nucl(j,i)=0.0d0
16420               gvdwpp(j,i)=0.0d0
16421               gelpp(j,i)=0.0d0
16422               gvdwpsb(j,i)=0.0d0
16423               gvdwpsb1(j,i)=0.0d0
16424               gvdwsbc(j,i)=0.0d0
16425               gvdwsbx(j,i)=0.0d0
16426               gelsbc(j,i)=0.0d0
16427               gradcorr_nucl(j,i)=0.0d0
16428               gradcorr3_nucl(j,i)=0.0d0
16429               gradxorr_nucl(j,i)=0.0d0
16430               gradxorr3_nucl(j,i)=0.0d0
16431               gelsbx(j,i)=0.0d0
16432               gsbloc(j,i)=0.0d0
16433               gsblocx(j,i)=0.0d0
16434               gradpepcat(j,i)=0.0d0
16435               gradpepcatx(j,i)=0.0d0
16436               gradcatcat(j,i)=0.0d0
16437               gvdwx_scbase(j,i)=0.0d0
16438               gvdwc_scbase(j,i)=0.0d0
16439               gvdwx_pepbase(j,i)=0.0d0
16440               gvdwc_pepbase(j,i)=0.0d0
16441               gvdwx_scpho(j,i)=0.0d0
16442               gvdwc_scpho(j,i)=0.0d0
16443               gvdwc_peppho(j,i)=0.0d0
16444             enddo
16445              enddo
16446             do i=0,nres
16447             do j=1,3
16448               do intertyp=1,3
16449                gloc_sc(intertyp,i,icg)=0.0d0
16450               enddo
16451             enddo
16452             enddo
16453             do i=1,nres
16454              do j=1,maxcontsshi
16455              shield_list(j,i)=0
16456             do k=1,3
16457       !C           print *,i,j,k
16458                grad_shield_side(k,j,i)=0.0d0
16459                grad_shield_loc(k,j,i)=0.0d0
16460              enddo
16461              enddo
16462              ishield_list(i)=0
16463             enddo
16464
16465       !
16466       ! Initialize the gradient of local energy terms.
16467       !
16468       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16469       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16470       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16471       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16472       !      allocate(gel_loc_turn3(nres))
16473       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16474       !      allocate(gsccor_loc(nres))      !(maxres)
16475
16476             do i=1,4*nres
16477             gloc(i,icg)=0.0D0
16478             enddo
16479             do i=1,nres
16480             gel_loc_loc(i)=0.0d0
16481             gcorr_loc(i)=0.0d0
16482             g_corr5_loc(i)=0.0d0
16483             g_corr6_loc(i)=0.0d0
16484             gel_loc_turn3(i)=0.0d0
16485             gel_loc_turn4(i)=0.0d0
16486             gel_loc_turn6(i)=0.0d0
16487             gsccor_loc(i)=0.0d0
16488             enddo
16489       ! initialize gcart and gxcart
16490       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16491             do i=0,nres
16492             do j=1,3
16493               gcart(j,i)=0.0d0
16494               gxcart(j,i)=0.0d0
16495             enddo
16496             enddo
16497             return
16498             end subroutine zerograd
16499       !-----------------------------------------------------------------------------
16500             real(kind=8) function fdum()
16501             fdum=0.0D0
16502             return
16503             end function fdum
16504       !-----------------------------------------------------------------------------
16505       ! intcartderiv.F
16506       !-----------------------------------------------------------------------------
16507             subroutine intcartderiv
16508       !      implicit real*8 (a-h,o-z)
16509       !      include 'DIMENSIONS'
16510 #ifdef MPI
16511             include 'mpif.h'
16512 #endif
16513       !      include 'COMMON.SETUP'
16514       !      include 'COMMON.CHAIN'
16515       !      include 'COMMON.VAR'
16516       !      include 'COMMON.GEO'
16517       !      include 'COMMON.INTERACT'
16518       !      include 'COMMON.DERIV'
16519       !      include 'COMMON.IOUNITS'
16520       !      include 'COMMON.LOCAL'
16521       !      include 'COMMON.SCCOR'
16522             real(kind=8) :: pi4,pi34
16523             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16524             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16525                       dcosomega,dsinomega !(3,3,maxres)
16526             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16527
16528             integer :: i,j,k
16529             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16530                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16531                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16532                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16533             integer :: nres2
16534             nres2=2*nres
16535
16536       !el from module energy-------------
16537       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16538       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16539       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16540
16541       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16542       !el      allocate(dsintau(3,3,3,0:nres2))
16543       !el      allocate(dtauangle(3,3,3,0:nres2))
16544       !el      allocate(domicron(3,2,2,0:nres2))
16545       !el      allocate(dcosomicron(3,2,2,0:nres2))
16546
16547
16548
16549 #if defined(MPI) && defined(PARINTDER)
16550             if (nfgtasks.gt.1 .and. me.eq.king) &
16551             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16552 #endif
16553             pi4 = 0.5d0*pipol
16554             pi34 = 3*pi4
16555
16556       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16557       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16558
16559       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16560             do i=1,nres
16561             do j=1,3
16562               dtheta(j,1,i)=0.0d0
16563               dtheta(j,2,i)=0.0d0
16564               dphi(j,1,i)=0.0d0
16565               dphi(j,2,i)=0.0d0
16566               dphi(j,3,i)=0.0d0
16567             enddo
16568             enddo
16569       ! Derivatives of theta's
16570 #if defined(MPI) && defined(PARINTDER)
16571       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16572             do i=max0(ithet_start-1,3),ithet_end
16573 #else
16574             do i=3,nres
16575 #endif
16576             cost=dcos(theta(i))
16577             sint=sqrt(1-cost*cost)
16578             do j=1,3
16579               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16580               vbld(i-1)
16581               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16582               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16583               vbld(i)
16584               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16585             enddo
16586             enddo
16587 #if defined(MPI) && defined(PARINTDER)
16588       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16589             do i=max0(ithet_start-1,3),ithet_end
16590 #else
16591             do i=3,nres
16592 #endif
16593             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16594             cost1=dcos(omicron(1,i))
16595             sint1=sqrt(1-cost1*cost1)
16596             cost2=dcos(omicron(2,i))
16597             sint2=sqrt(1-cost2*cost2)
16598              do j=1,3
16599       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16600               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16601               cost1*dc_norm(j,i-2))/ &
16602               vbld(i-1)
16603               domicron(j,1,1,i)=-1/sint1*dcosomicron(j,1,1,i)
16604               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16605               +cost1*(dc_norm(j,i-1+nres)))/ &
16606               vbld(i-1+nres)
16607               domicron(j,1,2,i)=-1/sint1*dcosomicron(j,1,2,i)
16608       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16609       !C Looks messy but better than if in loop
16610               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16611               +cost2*dc_norm(j,i-1))/ &
16612               vbld(i)
16613               domicron(j,2,1,i)=-1/sint2*dcosomicron(j,2,1,i)
16614               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16615                +cost2*(-dc_norm(j,i-1+nres)))/ &
16616               vbld(i-1+nres)
16617       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16618               domicron(j,2,2,i)=-1/sint2*dcosomicron(j,2,2,i)
16619             enddo
16620              endif
16621             enddo
16622       !elwrite(iout,*) "after vbld write"
16623       ! Derivatives of phi:
16624       ! If phi is 0 or 180 degrees, then the formulas
16625       ! have to be derived by power series expansion of the
16626       ! conventional formulas around 0 and 180.
16627 #ifdef PARINTDER
16628             do i=iphi1_start,iphi1_end
16629 #else
16630             do i=4,nres
16631 #endif
16632       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16633       ! the conventional case
16634             sint=dsin(theta(i))
16635             sint1=dsin(theta(i-1))
16636             sing=dsin(phi(i))
16637             cost=dcos(theta(i))
16638             cost1=dcos(theta(i-1))
16639             cosg=dcos(phi(i))
16640             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16641             fac0=1.0d0/(sint1*sint)
16642             fac1=cost*fac0
16643             fac2=cost1*fac0
16644             fac3=cosg*cost1/(sint1*sint1)
16645             fac4=cosg*cost/(sint*sint)
16646       !    Obtaining the gamma derivatives from sine derivative
16647              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16648                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16649                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16650              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16651              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16652              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16653              do j=1,3
16654                 ctgt=cost/sint
16655                 ctgt1=cost1/sint1
16656                 cosg_inv=1.0d0/cosg
16657                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16658                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16659                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16660                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16661                 dsinphi(j,2,i)= &
16662                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16663                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16664                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16665                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16666                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16667       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16668                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16669                 endif
16670       ! Bug fixed 3/24/05 (AL)
16671              enddo
16672       !   Obtaining the gamma derivatives from cosine derivative
16673             else
16674                do j=1,3
16675                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16676                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16677                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16678                dc_norm(j,i-3))/vbld(i-2)
16679                dphi(j,1,i)=-1/sing*dcosphi(j,1,i)
16680                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16681                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16682                dcostheta(j,1,i)
16683                dphi(j,2,i)=-1/sing*dcosphi(j,2,i)
16684                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16685                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16686                dc_norm(j,i-1))/vbld(i)
16687                dphi(j,3,i)=-1/sing*dcosphi(j,3,i)
16688                endif
16689              enddo
16690             endif
16691             enddo
16692       !alculate derivative of Tauangle
16693 #ifdef PARINTDER
16694             do i=itau_start,itau_end
16695 #else
16696             do i=3,nres
16697       !elwrite(iout,*) " vecpr",i,nres
16698 #endif
16699              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16700       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16701       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16702       !c dtauangle(j,intertyp,dervityp,residue number)
16703       !c INTERTYP=1 SC...Ca...Ca..Ca
16704       ! the conventional case
16705             sint=dsin(theta(i))
16706             sint1=dsin(omicron(2,i-1))
16707             sing=dsin(tauangle(1,i))
16708             cost=dcos(theta(i))
16709             cost1=dcos(omicron(2,i-1))
16710             cosg=dcos(tauangle(1,i))
16711       !elwrite(iout,*) " vecpr5",i,nres
16712             do j=1,3
16713       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16714       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16715             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16716       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16717             enddo
16718             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16719             fac0=1.0d0/(sint1*sint)
16720             fac1=cost*fac0
16721             fac2=cost1*fac0
16722             fac3=cosg*cost1/(sint1*sint1)
16723             fac4=cosg*cost/(sint*sint)
16724       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16725       !    Obtaining the gamma derivatives from sine derivative
16726              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16727                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16728                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16729              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16730              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16731              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16732             do j=1,3
16733                 ctgt=cost/sint
16734                 ctgt1=cost1/sint1
16735                 cosg_inv=1.0d0/cosg
16736                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16737              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16738              *vbld_inv(i-2+nres)
16739                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16740                 dsintau(j,1,2,i)= &
16741                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16742                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16743       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16744                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16745       ! Bug fixed 3/24/05 (AL)
16746                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16747                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16748       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16749                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16750              enddo
16751       !   Obtaining the gamma derivatives from cosine derivative
16752             else
16753                do j=1,3
16754                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16755                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16756                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16757                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16758                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16759                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16760                dcostheta(j,1,i)
16761                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16762                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16763                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16764                dc_norm(j,i-1))/vbld(i)
16765                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16766       !         write (iout,*) "else",i
16767              enddo
16768             endif
16769       !        do k=1,3
16770       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16771       !        enddo
16772             enddo
16773       !C Second case Ca...Ca...Ca...SC
16774 #ifdef PARINTDER
16775             do i=itau_start,itau_end
16776 #else
16777             do i=4,nres
16778 #endif
16779              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16780               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16781       ! the conventional case
16782             sint=dsin(omicron(1,i))
16783             sint1=dsin(theta(i-1))
16784             sing=dsin(tauangle(2,i))
16785             cost=dcos(omicron(1,i))
16786             cost1=dcos(theta(i-1))
16787             cosg=dcos(tauangle(2,i))
16788       !        do j=1,3
16789       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16790       !        enddo
16791             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16792             fac0=1.0d0/(sint1*sint)
16793             fac1=cost*fac0
16794             fac2=cost1*fac0
16795             fac3=cosg*cost1/(sint1*sint1)
16796             fac4=cosg*cost/(sint*sint)
16797       !    Obtaining the gamma derivatives from sine derivative
16798              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16799                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16800                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16801              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16802              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16803              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16804             do j=1,3
16805                 ctgt=cost/sint
16806                 ctgt1=cost1/sint1
16807                 cosg_inv=1.0d0/cosg
16808                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16809                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16810       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16811       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16812                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16813                 dsintau(j,2,2,i)= &
16814                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16815                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16816       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16817       !     & sing*ctgt*domicron(j,1,2,i),
16818       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16819                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16820       ! Bug fixed 3/24/05 (AL)
16821                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16822                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16823       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16824                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16825              enddo
16826       !   Obtaining the gamma derivatives from cosine derivative
16827             else
16828                do j=1,3
16829                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16830                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16831                dc_norm(j,i-3))/vbld(i-2)
16832                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16833                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16834                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16835                dcosomicron(j,1,1,i)
16836                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16837                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16838                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16839                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16840                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16841       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16842              enddo
16843             endif
16844             enddo
16845
16846       !CC third case SC...Ca...Ca...SC
16847 #ifdef PARINTDER
16848
16849             do i=itau_start,itau_end
16850 #else
16851             do i=3,nres
16852 #endif
16853       ! the conventional case
16854             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16855             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16856             sint=dsin(omicron(1,i))
16857             sint1=dsin(omicron(2,i-1))
16858             sing=dsin(tauangle(3,i))
16859             cost=dcos(omicron(1,i))
16860             cost1=dcos(omicron(2,i-1))
16861             cosg=dcos(tauangle(3,i))
16862             do j=1,3
16863             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16864       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16865             enddo
16866             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16867             fac0=1.0d0/(sint1*sint)
16868             fac1=cost*fac0
16869             fac2=cost1*fac0
16870             fac3=cosg*cost1/(sint1*sint1)
16871             fac4=cosg*cost/(sint*sint)
16872       !    Obtaining the gamma derivatives from sine derivative
16873              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16874                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16875                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16876              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16877              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16878              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16879             do j=1,3
16880                 ctgt=cost/sint
16881                 ctgt1=cost1/sint1
16882                 cosg_inv=1.0d0/cosg
16883                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16884                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16885                   *vbld_inv(i-2+nres)
16886                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16887                 dsintau(j,3,2,i)= &
16888                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16889                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16890                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16891       ! Bug fixed 3/24/05 (AL)
16892                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16893                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16894                   *vbld_inv(i-1+nres)
16895       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16896                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16897              enddo
16898       !   Obtaining the gamma derivatives from cosine derivative
16899             else
16900                do j=1,3
16901                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16902                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16903                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16904                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16905                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16906                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16907                dcosomicron(j,1,1,i)
16908                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16909                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16910                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16911                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16912                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16913       !          write(iout,*) "else",i
16914              enddo
16915             endif
16916             enddo
16917
16918 #ifdef CRYST_SC
16919       !   Derivatives of side-chain angles alpha and omega
16920 #if defined(MPI) && defined(PARINTDER)
16921             do i=ibond_start,ibond_end
16922 #else
16923             do i=2,nres-1
16924 #endif
16925               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16926                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16927                  fac6=fac5/vbld(i)
16928                  fac7=fac5*fac5
16929                  fac8=fac5/vbld(i+1)
16930                  fac9=fac5/vbld(i+nres)
16931                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16932                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16933                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16934                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16935                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16936                  sina=sqrt(1-cosa*cosa)
16937                  sino=dsin(omeg(i))
16938       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16939                  do j=1,3
16940                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16941                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16942                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16943                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16944                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16945                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16946                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16947                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16948                   vbld(i+nres))
16949                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16950                 enddo
16951       ! obtaining the derivatives of omega from sines
16952                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16953                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16954                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
16955                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
16956                    dsin(theta(i+1)))
16957                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
16958                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
16959                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
16960                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
16961                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
16962                    coso_inv=1.0d0/dcos(omeg(i))
16963                    do j=1,3
16964                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
16965                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
16966                    (sino*dc_norm(j,i-1))/vbld(i)
16967                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
16968                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
16969                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
16970                    -sino*dc_norm(j,i)/vbld(i+1)
16971                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
16972                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
16973                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
16974                    vbld(i+nres)
16975                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
16976                   enddo
16977                else
16978       !   obtaining the derivatives of omega from cosines
16979                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
16980                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
16981                  fac12=fac10*sina
16982                  fac13=fac12*fac12
16983                  fac14=sina*sina
16984                  do j=1,3
16985                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
16986                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
16987                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
16988                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
16989                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
16990                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
16991                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
16992                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
16993                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
16994                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
16995                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
16996                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
16997                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
16998                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
16999                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17000                 enddo
17001               endif
17002              else
17003                do j=1,3
17004                  do k=1,3
17005                    dalpha(k,j,i)=0.0d0
17006                    domega(k,j,i)=0.0d0
17007                  enddo
17008                enddo
17009              endif
17010              enddo
17011 #endif
17012 #if defined(MPI) && defined(PARINTDER)
17013             if (nfgtasks.gt.1) then
17014 #ifdef DEBUG
17015       !d      write (iout,*) "Gather dtheta"
17016       !d      call flush(iout)
17017             write (iout,*) "dtheta before gather"
17018             do i=1,nres
17019             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17020             enddo
17021 #endif
17022             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17023             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17024             king,FG_COMM,IERROR)
17025 #ifdef DEBUG
17026       !d      write (iout,*) "Gather dphi"
17027       !d      call flush(iout)
17028             write (iout,*) "dphi before gather"
17029             do i=1,nres
17030             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17031             enddo
17032 #endif
17033             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17034             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17035             king,FG_COMM,IERROR)
17036       !d      write (iout,*) "Gather dalpha"
17037       !d      call flush(iout)
17038 #ifdef CRYST_SC
17039             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17040             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17041             king,FG_COMM,IERROR)
17042       !d      write (iout,*) "Gather domega"
17043       !d      call flush(iout)
17044             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17045             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17046             king,FG_COMM,IERROR)
17047 #endif
17048             endif
17049 #endif
17050 #ifdef DEBUG
17051             write (iout,*) "dtheta after gather"
17052             do i=1,nres
17053             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17054             enddo
17055             write (iout,*) "dphi after gather"
17056             do i=1,nres
17057             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17058             enddo
17059             write (iout,*) "dalpha after gather"
17060             do i=1,nres
17061             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17062             enddo
17063             write (iout,*) "domega after gather"
17064             do i=1,nres
17065             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17066             enddo
17067 #endif
17068             return
17069             end subroutine intcartderiv
17070       !-----------------------------------------------------------------------------
17071             subroutine checkintcartgrad
17072       !      implicit real*8 (a-h,o-z)
17073       !      include 'DIMENSIONS'
17074 #ifdef MPI
17075             include 'mpif.h'
17076 #endif
17077       !      include 'COMMON.CHAIN'
17078       !      include 'COMMON.VAR'
17079       !      include 'COMMON.GEO'
17080       !      include 'COMMON.INTERACT'
17081       !      include 'COMMON.DERIV'
17082       !      include 'COMMON.IOUNITS'
17083       !      include 'COMMON.SETUP'
17084             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17085             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17086             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17087             real(kind=8),dimension(3) :: dc_norm_s
17088             real(kind=8) :: aincr=1.0d-5
17089             integer :: i,j
17090             real(kind=8) :: dcji
17091             do i=1,nres
17092             phi_s(i)=phi(i)
17093             theta_s(i)=theta(i)
17094             alph_s(i)=alph(i)
17095             omeg_s(i)=omeg(i)
17096             enddo
17097       ! Check theta gradient
17098             write (iout,*) &
17099              "Analytical (upper) and numerical (lower) gradient of theta"
17100             write (iout,*)
17101             do i=3,nres
17102             do j=1,3
17103               dcji=dc(j,i-2)
17104               dc(j,i-2)=dcji+aincr
17105               call chainbuild_cart
17106               call int_from_cart1(.false.)
17107           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17108           dc(j,i-2)=dcji
17109           dcji=dc(j,i-1)
17110           dc(j,i-1)=dc(j,i-1)+aincr
17111           call chainbuild_cart
17112           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17113           dc(j,i-1)=dcji
17114         enddo
17115 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17116 !el          (dtheta(j,2,i),j=1,3)
17117 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17118 !el          (dthetanum(j,2,i),j=1,3)
17119 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17120 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17121 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17122 !el        write (iout,*)
17123       enddo
17124 ! Check gamma gradient
17125       write (iout,*) &
17126        "Analytical (upper) and numerical (lower) gradient of gamma"
17127       do i=4,nres
17128         do j=1,3
17129           dcji=dc(j,i-3)
17130           dc(j,i-3)=dcji+aincr
17131           call chainbuild_cart
17132           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17133               dc(j,i-3)=dcji
17134           dcji=dc(j,i-2)
17135           dc(j,i-2)=dcji+aincr
17136           call chainbuild_cart
17137           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17138           dc(j,i-2)=dcji
17139           dcji=dc(j,i-1)
17140           dc(j,i-1)=dc(j,i-1)+aincr
17141           call chainbuild_cart
17142           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17143           dc(j,i-1)=dcji
17144         enddo
17145 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17146 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17147 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17148 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17149 !el        write (iout,'(5x,3(3f10.5,5x))') &
17150 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17151 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17152 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17153 !el        write (iout,*)
17154       enddo
17155 ! Check alpha gradient
17156       write (iout,*) &
17157        "Analytical (upper) and numerical (lower) gradient of alpha"
17158       do i=2,nres-1
17159        if(itype(i,1).ne.10) then
17160                  do j=1,3
17161                   dcji=dc(j,i-1)
17162                    dc(j,i-1)=dcji+aincr
17163               call chainbuild_cart
17164               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17165                  /aincr
17166                   dc(j,i-1)=dcji
17167               dcji=dc(j,i)
17168               dc(j,i)=dcji+aincr
17169               call chainbuild_cart
17170               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17171                  /aincr
17172               dc(j,i)=dcji
17173               dcji=dc(j,i+nres)
17174               dc(j,i+nres)=dc(j,i+nres)+aincr
17175               call chainbuild_cart
17176               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17177                  /aincr
17178              dc(j,i+nres)=dcji
17179             enddo
17180           endif
17181 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17182 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17183 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17184 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17185 !el        write (iout,'(5x,3(3f10.5,5x))') &
17186 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17187 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17188 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17189 !el        write (iout,*)
17190       enddo
17191 !     Check omega gradient
17192       write (iout,*) &
17193        "Analytical (upper) and numerical (lower) gradient of omega"
17194       do i=2,nres-1
17195        if(itype(i,1).ne.10) then
17196                  do j=1,3
17197                   dcji=dc(j,i-1)
17198                    dc(j,i-1)=dcji+aincr
17199               call chainbuild_cart
17200               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17201                  /aincr
17202                   dc(j,i-1)=dcji
17203               dcji=dc(j,i)
17204               dc(j,i)=dcji+aincr
17205               call chainbuild_cart
17206               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17207                  /aincr
17208               dc(j,i)=dcji
17209               dcji=dc(j,i+nres)
17210               dc(j,i+nres)=dc(j,i+nres)+aincr
17211               call chainbuild_cart
17212               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17213                  /aincr
17214              dc(j,i+nres)=dcji
17215             enddo
17216           endif
17217 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17218 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17219 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17220 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17221 !el        write (iout,'(5x,3(3f10.5,5x))') &
17222 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17223 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17224 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17225 !el        write (iout,*)
17226       enddo
17227       return
17228       end subroutine checkintcartgrad
17229 !-----------------------------------------------------------------------------
17230 ! q_measure.F
17231 !-----------------------------------------------------------------------------
17232       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17233 !      implicit real*8 (a-h,o-z)
17234 !      include 'DIMENSIONS'
17235 !      include 'COMMON.IOUNITS'
17236 !      include 'COMMON.CHAIN'
17237 !      include 'COMMON.INTERACT'
17238 !      include 'COMMON.VAR'
17239       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17240       integer :: kkk,nsep=3
17241       real(kind=8) :: qm      !dist,
17242       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17243       logical :: lprn=.false.
17244       logical :: flag
17245 !      real(kind=8) :: sigm,x
17246
17247 !el      sigm(x)=0.25d0*x     ! local function
17248       qqmax=1.0d10
17249       do kkk=1,nperm
17250       qq = 0.0d0
17251       nl=0
17252        if(flag) then
17253         do il=seg1+nsep,seg2
17254           do jl=seg1,il-nsep
17255             nl=nl+1
17256             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17257                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17258                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17259             dij=dist(il,jl)
17260             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17261             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17262               nl=nl+1
17263               d0ijCM=dsqrt( &
17264                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17265                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17266                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17267               dijCM=dist(il+nres,jl+nres)
17268               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17269             endif
17270             qq = qq+qqij+qqijCM
17271           enddo
17272         enddo
17273         qq = qq/nl
17274       else
17275       do il=seg1,seg2
17276         if((seg3-il).lt.3) then
17277              secseg=il+3
17278         else
17279              secseg=seg3
17280         endif
17281           do jl=secseg,seg4
17282             nl=nl+1
17283             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17284                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17285                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17286             dij=dist(il,jl)
17287             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17288             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17289               nl=nl+1
17290               d0ijCM=dsqrt( &
17291                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17292                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17293                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17294               dijCM=dist(il+nres,jl+nres)
17295               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17296             endif
17297             qq = qq+qqij+qqijCM
17298           enddo
17299         enddo
17300       qq = qq/nl
17301       endif
17302       if (qqmax.le.qq) qqmax=qq
17303       enddo
17304       qwolynes=1.0d0-qqmax
17305       return
17306       end function qwolynes
17307 !-----------------------------------------------------------------------------
17308       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17309 !      implicit real*8 (a-h,o-z)
17310 !      include 'DIMENSIONS'
17311 !      include 'COMMON.IOUNITS'
17312 !      include 'COMMON.CHAIN'
17313 !      include 'COMMON.INTERACT'
17314 !      include 'COMMON.VAR'
17315 !      include 'COMMON.MD'
17316       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17317       integer :: nsep=3, kkk
17318 !el      real(kind=8) :: dist
17319       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17320       logical :: lprn=.false.
17321       logical :: flag
17322       real(kind=8) :: sim,dd0,fac,ddqij
17323 !el      sigm(x)=0.25d0*x           ! local function
17324       do kkk=1,nperm
17325       do i=0,nres
17326         do j=1,3
17327           dqwol(j,i)=0.0d0
17328           dxqwol(j,i)=0.0d0
17329         enddo
17330       enddo
17331       nl=0
17332        if(flag) then
17333         do il=seg1+nsep,seg2
17334           do jl=seg1,il-nsep
17335             nl=nl+1
17336             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17337                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17338                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17339             dij=dist(il,jl)
17340             sim = 1.0d0/sigm(d0ij)
17341             sim = sim*sim
17342             dd0 = dij-d0ij
17343             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17344           do k=1,3
17345               ddqij = (c(k,il)-c(k,jl))*fac
17346               dqwol(k,il)=dqwol(k,il)+ddqij
17347               dqwol(k,jl)=dqwol(k,jl)-ddqij
17348             enddo
17349
17350             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17351               nl=nl+1
17352               d0ijCM=dsqrt( &
17353                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17354                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17355                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17356               dijCM=dist(il+nres,jl+nres)
17357               sim = 1.0d0/sigm(d0ijCM)
17358               sim = sim*sim
17359               dd0=dijCM-d0ijCM
17360               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17361               do k=1,3
17362                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17363                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17364                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17365               enddo
17366             endif
17367           enddo
17368         enddo
17369        else
17370         do il=seg1,seg2
17371         if((seg3-il).lt.3) then
17372              secseg=il+3
17373         else
17374              secseg=seg3
17375         endif
17376           do jl=secseg,seg4
17377             nl=nl+1
17378             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17379                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17380                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17381             dij=dist(il,jl)
17382             sim = 1.0d0/sigm(d0ij)
17383             sim = sim*sim
17384             dd0 = dij-d0ij
17385             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17386             do k=1,3
17387               ddqij = (c(k,il)-c(k,jl))*fac
17388               dqwol(k,il)=dqwol(k,il)+ddqij
17389               dqwol(k,jl)=dqwol(k,jl)-ddqij
17390             enddo
17391             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17392               nl=nl+1
17393               d0ijCM=dsqrt( &
17394                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17395                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17396                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17397               dijCM=dist(il+nres,jl+nres)
17398               sim = 1.0d0/sigm(d0ijCM)
17399               sim=sim*sim
17400               dd0 = dijCM-d0ijCM
17401               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17402               do k=1,3
17403                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17404                dxqwol(k,il)=dxqwol(k,il)+ddqij
17405                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17406               enddo
17407             endif
17408           enddo
17409         enddo
17410       endif
17411       enddo
17412        do i=0,nres
17413          do j=1,3
17414            dqwol(j,i)=dqwol(j,i)/nl
17415            dxqwol(j,i)=dxqwol(j,i)/nl
17416          enddo
17417        enddo
17418       return
17419       end subroutine qwolynes_prim
17420 !-----------------------------------------------------------------------------
17421       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17422 !      implicit real*8 (a-h,o-z)
17423 !      include 'DIMENSIONS'
17424 !      include 'COMMON.IOUNITS'
17425 !      include 'COMMON.CHAIN'
17426 !      include 'COMMON.INTERACT'
17427 !      include 'COMMON.VAR'
17428       integer :: seg1,seg2,seg3,seg4
17429       logical :: flag
17430       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17431       real(kind=8),dimension(3,0:2*nres) :: cdummy
17432       real(kind=8) :: q1,q2
17433       real(kind=8) :: delta=1.0d-10
17434       integer :: i,j
17435
17436       do i=0,nres
17437         do j=1,3
17438           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17439           cdummy(j,i)=c(j,i)
17440           c(j,i)=c(j,i)+delta
17441           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17442           qwolan(j,i)=(q2-q1)/delta
17443           c(j,i)=cdummy(j,i)
17444         enddo
17445       enddo
17446       do i=0,nres
17447         do j=1,3
17448           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17449           cdummy(j,i+nres)=c(j,i+nres)
17450           c(j,i+nres)=c(j,i+nres)+delta
17451           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17452           qwolxan(j,i)=(q2-q1)/delta
17453           c(j,i+nres)=cdummy(j,i+nres)
17454         enddo
17455       enddo
17456 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17457 !      do i=0,nct
17458 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17459 !      enddo
17460 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17461 !      do i=0,nct
17462 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17463 !      enddo
17464       return
17465       end subroutine qwol_num
17466 !-----------------------------------------------------------------------------
17467       subroutine EconstrQ
17468 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17469 !      implicit real*8 (a-h,o-z)
17470 !      include 'DIMENSIONS'
17471 !      include 'COMMON.CONTROL'
17472 !      include 'COMMON.VAR'
17473 !      include 'COMMON.MD'
17474       use MD_data
17475 !#ifndef LANG0
17476 !      include 'COMMON.LANGEVIN'
17477 !#else
17478 !      include 'COMMON.LANGEVIN.lang0'
17479 !#endif
17480 !      include 'COMMON.CHAIN'
17481 !      include 'COMMON.DERIV'
17482 !      include 'COMMON.GEO'
17483 !      include 'COMMON.LOCAL'
17484 !      include 'COMMON.INTERACT'
17485 !      include 'COMMON.IOUNITS'
17486 !      include 'COMMON.NAMES'
17487 !      include 'COMMON.TIME1'
17488       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17489       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17490                    duconst,duxconst
17491       integer :: kstart,kend,lstart,lend,idummy
17492       real(kind=8) :: delta=1.0d-7
17493       integer :: i,j,k,ii
17494       do i=0,nres
17495          do j=1,3
17496             duconst(j,i)=0.0d0
17497             dudconst(j,i)=0.0d0
17498             duxconst(j,i)=0.0d0
17499             dudxconst(j,i)=0.0d0
17500          enddo
17501       enddo
17502       Uconst=0.0d0
17503       do i=1,nfrag
17504          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17505            idummy,idummy)
17506          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17507 ! Calculating the derivatives of Constraint energy with respect to Q
17508          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17509            qinfrag(i,iset))
17510 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17511 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17512 !         hmnum=(hm2-hm1)/delta
17513 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17514 !     &   qinfrag(i,iset))
17515 !         write(iout,*) "harmonicnum frag", hmnum
17516 ! Calculating the derivatives of Q with respect to cartesian coordinates
17517          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17518           idummy,idummy)
17519 !         write(iout,*) "dqwol "
17520 !         do ii=1,nres
17521 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17522 !         enddo
17523 !         write(iout,*) "dxqwol "
17524 !         do ii=1,nres
17525 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17526 !         enddo
17527 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17528 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17529 !     &  ,idummy,idummy)
17530 !  The gradients of Uconst in Cs
17531          do ii=0,nres
17532             do j=1,3
17533                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17534                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17535             enddo
17536          enddo
17537       enddo
17538       do i=1,npair
17539          kstart=ifrag(1,ipair(1,i,iset),iset)
17540          kend=ifrag(2,ipair(1,i,iset),iset)
17541          lstart=ifrag(1,ipair(2,i,iset),iset)
17542          lend=ifrag(2,ipair(2,i,iset),iset)
17543          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17544          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17545 !  Calculating dU/dQ
17546          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17547 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17548 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17549 !         hmnum=(hm2-hm1)/delta
17550 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17551 !     &   qinpair(i,iset))
17552 !         write(iout,*) "harmonicnum pair ", hmnum
17553 ! Calculating dQ/dXi
17554          call qwolynes_prim(kstart,kend,.false.,&
17555           lstart,lend)
17556 !         write(iout,*) "dqwol "
17557 !         do ii=1,nres
17558 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17559 !         enddo
17560 !         write(iout,*) "dxqwol "
17561 !         do ii=1,nres
17562 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17563 !        enddo
17564 ! Calculating numerical gradients
17565 !        call qwol_num(kstart,kend,.false.
17566 !     &  ,lstart,lend)
17567 ! The gradients of Uconst in Cs
17568          do ii=0,nres
17569             do j=1,3
17570                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17571                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17572             enddo
17573          enddo
17574       enddo
17575 !      write(iout,*) "Uconst inside subroutine ", Uconst
17576 ! Transforming the gradients from Cs to dCs for the backbone
17577       do i=0,nres
17578          do j=i+1,nres
17579            do k=1,3
17580              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17581            enddo
17582          enddo
17583       enddo
17584 !  Transforming the gradients from Cs to dCs for the side chains
17585       do i=1,nres
17586          do j=1,3
17587            dudxconst(j,i)=duxconst(j,i)
17588          enddo
17589       enddo
17590 !      write(iout,*) "dU/ddc backbone "
17591 !       do ii=0,nres
17592 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17593 !      enddo
17594 !      write(iout,*) "dU/ddX side chain "
17595 !      do ii=1,nres
17596 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17597 !      enddo
17598 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17599 !      call dEconstrQ_num
17600       return
17601       end subroutine EconstrQ
17602 !-----------------------------------------------------------------------------
17603       subroutine dEconstrQ_num
17604 ! Calculating numerical dUconst/ddc and dUconst/ddx
17605 !      implicit real*8 (a-h,o-z)
17606 !      include 'DIMENSIONS'
17607 !      include 'COMMON.CONTROL'
17608 !      include 'COMMON.VAR'
17609 !      include 'COMMON.MD'
17610       use MD_data
17611 !#ifndef LANG0
17612 !      include 'COMMON.LANGEVIN'
17613 !#else
17614 !      include 'COMMON.LANGEVIN.lang0'
17615 !#endif
17616 !      include 'COMMON.CHAIN'
17617 !      include 'COMMON.DERIV'
17618 !      include 'COMMON.GEO'
17619 !      include 'COMMON.LOCAL'
17620 !      include 'COMMON.INTERACT'
17621 !      include 'COMMON.IOUNITS'
17622 !      include 'COMMON.NAMES'
17623 !      include 'COMMON.TIME1'
17624       real(kind=8) :: uzap1,uzap2
17625       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17626       integer :: kstart,kend,lstart,lend,idummy
17627       real(kind=8) :: delta=1.0d-7
17628 !el local variables
17629       integer :: i,ii,j
17630 !     real(kind=8) ::
17631 !     For the backbone
17632       do i=0,nres-1
17633          do j=1,3
17634             dUcartan(j,i)=0.0d0
17635             cdummy(j,i)=dc(j,i)
17636             dc(j,i)=dc(j,i)+delta
17637             call chainbuild_cart
17638           uzap2=0.0d0
17639             do ii=1,nfrag
17640              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17641                 idummy,idummy)
17642                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17643                 qinfrag(ii,iset))
17644             enddo
17645             do ii=1,npair
17646                kstart=ifrag(1,ipair(1,ii,iset),iset)
17647                kend=ifrag(2,ipair(1,ii,iset),iset)
17648                lstart=ifrag(1,ipair(2,ii,iset),iset)
17649                lend=ifrag(2,ipair(2,ii,iset),iset)
17650                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17651                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17652                  qinpair(ii,iset))
17653             enddo
17654             dc(j,i)=cdummy(j,i)
17655             call chainbuild_cart
17656             uzap1=0.0d0
17657              do ii=1,nfrag
17658              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17659                 idummy,idummy)
17660                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17661                 qinfrag(ii,iset))
17662             enddo
17663             do ii=1,npair
17664                kstart=ifrag(1,ipair(1,ii,iset),iset)
17665                kend=ifrag(2,ipair(1,ii,iset),iset)
17666                lstart=ifrag(1,ipair(2,ii,iset),iset)
17667                lend=ifrag(2,ipair(2,ii,iset),iset)
17668                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17669                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17670                 qinpair(ii,iset))
17671             enddo
17672             ducartan(j,i)=(uzap2-uzap1)/(delta)
17673          enddo
17674       enddo
17675 ! Calculating numerical gradients for dU/ddx
17676       do i=0,nres-1
17677          duxcartan(j,i)=0.0d0
17678          do j=1,3
17679             cdummy(j,i)=dc(j,i+nres)
17680             dc(j,i+nres)=dc(j,i+nres)+delta
17681             call chainbuild_cart
17682           uzap2=0.0d0
17683             do ii=1,nfrag
17684              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17685                 idummy,idummy)
17686                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17687                 qinfrag(ii,iset))
17688             enddo
17689             do ii=1,npair
17690                kstart=ifrag(1,ipair(1,ii,iset),iset)
17691                kend=ifrag(2,ipair(1,ii,iset),iset)
17692                lstart=ifrag(1,ipair(2,ii,iset),iset)
17693                lend=ifrag(2,ipair(2,ii,iset),iset)
17694                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17695                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17696                 qinpair(ii,iset))
17697             enddo
17698             dc(j,i+nres)=cdummy(j,i)
17699             call chainbuild_cart
17700             uzap1=0.0d0
17701              do ii=1,nfrag
17702                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17703                 ifrag(2,ii,iset),.true.,idummy,idummy)
17704                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17705                 qinfrag(ii,iset))
17706             enddo
17707             do ii=1,npair
17708                kstart=ifrag(1,ipair(1,ii,iset),iset)
17709                kend=ifrag(2,ipair(1,ii,iset),iset)
17710                lstart=ifrag(1,ipair(2,ii,iset),iset)
17711                lend=ifrag(2,ipair(2,ii,iset),iset)
17712                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17713                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17714                 qinpair(ii,iset))
17715             enddo
17716             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17717          enddo
17718       enddo
17719       write(iout,*) "Numerical dUconst/ddc backbone "
17720       do ii=0,nres
17721         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17722       enddo
17723 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17724 !      do ii=1,nres
17725 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17726 !      enddo
17727       return
17728       end subroutine dEconstrQ_num
17729 !-----------------------------------------------------------------------------
17730 ! ssMD.F
17731 !-----------------------------------------------------------------------------
17732       subroutine check_energies
17733
17734 !      use random, only: ran_number
17735
17736 !      implicit none
17737 !     Includes
17738 !      include 'DIMENSIONS'
17739 !      include 'COMMON.CHAIN'
17740 !      include 'COMMON.VAR'
17741 !      include 'COMMON.IOUNITS'
17742 !      include 'COMMON.SBRIDGE'
17743 !      include 'COMMON.LOCAL'
17744 !      include 'COMMON.GEO'
17745
17746 !     External functions
17747 !EL      double precision ran_number
17748 !EL      external ran_number
17749
17750 !     Local variables
17751       integer :: i,j,k,l,lmax,p,pmax
17752       real(kind=8) :: rmin,rmax
17753       real(kind=8) :: eij
17754
17755       real(kind=8) :: d
17756       real(kind=8) :: wi,rij,tj,pj
17757 !      return
17758
17759       i=5
17760       j=14
17761
17762       d=dsc(1)
17763       rmin=2.0D0
17764       rmax=12.0D0
17765
17766       lmax=10000
17767       pmax=1
17768
17769       do k=1,3
17770         c(k,i)=0.0D0
17771         c(k,j)=0.0D0
17772         c(k,nres+i)=0.0D0
17773         c(k,nres+j)=0.0D0
17774       enddo
17775
17776       do l=1,lmax
17777
17778 !t        wi=ran_number(0.0D0,pi)
17779 !        wi=ran_number(0.0D0,pi/6.0D0)
17780 !        wi=0.0D0
17781 !t        tj=ran_number(0.0D0,pi)
17782 !t        pj=ran_number(0.0D0,pi)
17783 !        pj=ran_number(0.0D0,pi/6.0D0)
17784 !        pj=0.0D0
17785
17786         do p=1,pmax
17787 !t           rij=ran_number(rmin,rmax)
17788
17789            c(1,j)=d*sin(pj)*cos(tj)
17790            c(2,j)=d*sin(pj)*sin(tj)
17791            c(3,j)=d*cos(pj)
17792
17793            c(3,nres+i)=-rij
17794
17795            c(1,i)=d*sin(wi)
17796            c(3,i)=-rij-d*cos(wi)
17797
17798            do k=1,3
17799               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17800               dc_norm(k,nres+i)=dc(k,nres+i)/d
17801               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17802               dc_norm(k,nres+j)=dc(k,nres+j)/d
17803            enddo
17804
17805            call dyn_ssbond_ene(i,j,eij)
17806         enddo
17807       enddo
17808       call exit(1)
17809       return
17810       end subroutine check_energies
17811 !-----------------------------------------------------------------------------
17812       subroutine dyn_ssbond_ene(resi,resj,eij)
17813 !      implicit none
17814 !      Includes
17815       use calc_data
17816       use comm_sschecks
17817 !      include 'DIMENSIONS'
17818 !      include 'COMMON.SBRIDGE'
17819 !      include 'COMMON.CHAIN'
17820 !      include 'COMMON.DERIV'
17821 !      include 'COMMON.LOCAL'
17822 !      include 'COMMON.INTERACT'
17823 !      include 'COMMON.VAR'
17824 !      include 'COMMON.IOUNITS'
17825 !      include 'COMMON.CALC'
17826 #ifndef CLUST
17827 #ifndef WHAM
17828        use MD_data
17829 !      include 'COMMON.MD'
17830 !      use MD, only: totT,t_bath
17831 #endif
17832 #endif
17833 !     External functions
17834 !EL      double precision h_base
17835 !EL      external h_base
17836
17837 !     Input arguments
17838       integer :: resi,resj
17839
17840 !     Output arguments
17841       real(kind=8) :: eij
17842
17843 !     Local variables
17844       logical :: havebond
17845       integer itypi,itypj
17846       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17847       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17848       real(kind=8),dimension(3) :: dcosom1,dcosom2
17849       real(kind=8) :: ed
17850       real(kind=8) :: pom1,pom2
17851       real(kind=8) :: ljA,ljB,ljXs
17852       real(kind=8),dimension(1:3) :: d_ljB
17853       real(kind=8) :: ssA,ssB,ssC,ssXs
17854       real(kind=8) :: ssxm,ljxm,ssm,ljm
17855       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17856       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17857       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17858 !-------FIRST METHOD
17859       real(kind=8) :: xm
17860       real(kind=8),dimension(1:3) :: d_xm
17861 !-------END FIRST METHOD
17862 !-------SECOND METHOD
17863 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17864 !-------END SECOND METHOD
17865
17866 !-------TESTING CODE
17867 !el      logical :: checkstop,transgrad
17868 !el      common /sschecks/ checkstop,transgrad
17869
17870       integer :: icheck,nicheck,jcheck,njcheck
17871       real(kind=8),dimension(-1:1) :: echeck
17872       real(kind=8) :: deps,ssx0,ljx0
17873 !-------END TESTING CODE
17874
17875       eij=0.0d0
17876       i=resi
17877       j=resj
17878
17879 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17880 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17881
17882       itypi=itype(i,1)
17883       dxi=dc_norm(1,nres+i)
17884       dyi=dc_norm(2,nres+i)
17885       dzi=dc_norm(3,nres+i)
17886       dsci_inv=vbld_inv(i+nres)
17887
17888       itypj=itype(j,1)
17889       xj=c(1,nres+j)-c(1,nres+i)
17890       yj=c(2,nres+j)-c(2,nres+i)
17891       zj=c(3,nres+j)-c(3,nres+i)
17892       dxj=dc_norm(1,nres+j)
17893       dyj=dc_norm(2,nres+j)
17894       dzj=dc_norm(3,nres+j)
17895       dscj_inv=vbld_inv(j+nres)
17896
17897       chi1=chi(itypi,itypj)
17898       chi2=chi(itypj,itypi)
17899       chi12=chi1*chi2
17900       chip1=chip(itypi)
17901       chip2=chip(itypj)
17902       chip12=chip1*chip2
17903       alf1=alp(itypi)
17904       alf2=alp(itypj)
17905       alf12=0.5D0*(alf1+alf2)
17906
17907       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17908       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17909 !     The following are set in sc_angular
17910 !      erij(1)=xj*rij
17911 !      erij(2)=yj*rij
17912 !      erij(3)=zj*rij
17913 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17914 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17915 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17916       call sc_angular
17917       rij=1.0D0/rij  ! Reset this so it makes sense
17918
17919       sig0ij=sigma(itypi,itypj)
17920       sig=sig0ij*dsqrt(1.0D0/sigsq)
17921
17922       ljXs=sig-sig0ij
17923       ljA=eps1*eps2rt**2*eps3rt**2
17924       ljB=ljA*bb_aq(itypi,itypj)
17925       ljA=ljA*aa_aq(itypi,itypj)
17926       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17927
17928       ssXs=d0cm
17929       deltat1=1.0d0-om1
17930       deltat2=1.0d0+om2
17931       deltat12=om2-om1+2.0d0
17932       cosphi=om12-om1*om2
17933       ssA=akcm
17934       ssB=akct*deltat12
17935       ssC=ss_depth &
17936            +akth*(deltat1*deltat1+deltat2*deltat2) &
17937            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17938       ssxm=ssXs-0.5D0*ssB/ssA
17939
17940 !-------TESTING CODE
17941 !$$$c     Some extra output
17942 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17943 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17944 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17945 !$$$      if (ssx0.gt.0.0d0) then
17946 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17947 !$$$      else
17948 !$$$        ssx0=ssxm
17949 !$$$      endif
17950 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
17951 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
17952 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
17953 !$$$      return
17954 !-------END TESTING CODE
17955
17956 !-------TESTING CODE
17957 !     Stop and plot energy and derivative as a function of distance
17958       if (checkstop) then
17959         ssm=ssC-0.25D0*ssB*ssB/ssA
17960         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
17961         if (ssm.lt.ljm .and. &
17962              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
17963           nicheck=1000
17964           njcheck=1
17965           deps=0.5d-7
17966         else
17967           checkstop=.false.
17968         endif
17969       endif
17970       if (.not.checkstop) then
17971         nicheck=0
17972         njcheck=-1
17973       endif
17974
17975       do icheck=0,nicheck
17976       do jcheck=-1,njcheck
17977       if (checkstop) rij=(ssxm-1.0d0)+ &
17978              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
17979 !-------END TESTING CODE
17980
17981       if (rij.gt.ljxm) then
17982         havebond=.false.
17983         ljd=rij-ljXs
17984         fac=(1.0D0/ljd)**expon
17985         e1=fac*fac*aa_aq(itypi,itypj)
17986         e2=fac*bb_aq(itypi,itypj)
17987         eij=eps1*eps2rt*eps3rt*(e1+e2)
17988         eps2der=eij*eps3rt
17989         eps3der=eij*eps2rt
17990         eij=eij*eps2rt*eps3rt
17991
17992         sigder=-sig/sigsq
17993         e1=e1*eps1*eps2rt**2*eps3rt**2
17994         ed=-expon*(e1+eij)/ljd
17995         sigder=ed*sigder
17996         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
17997         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
17998         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
17999              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18000       else if (rij.lt.ssxm) then
18001         havebond=.true.
18002         ssd=rij-ssXs
18003         eij=ssA*ssd*ssd+ssB*ssd+ssC
18004
18005         ed=2*akcm*ssd+akct*deltat12
18006         pom1=akct*ssd
18007         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18008         eom1=-2*akth*deltat1-pom1-om2*pom2
18009         eom2= 2*akth*deltat2+pom1-om1*pom2
18010         eom12=pom2
18011       else
18012         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18013
18014         d_ssxm(1)=0.5D0*akct/ssA
18015         d_ssxm(2)=-d_ssxm(1)
18016         d_ssxm(3)=0.0D0
18017
18018         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18019         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18020         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18021         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18022
18023 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18024         xm=0.5d0*(ssxm+ljxm)
18025         do k=1,3
18026           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18027         enddo
18028         if (rij.lt.xm) then
18029           havebond=.true.
18030           ssm=ssC-0.25D0*ssB*ssB/ssA
18031           d_ssm(1)=0.5D0*akct*ssB/ssA
18032           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18033           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18034           d_ssm(3)=omega
18035           f1=(rij-xm)/(ssxm-xm)
18036           f2=(rij-ssxm)/(xm-ssxm)
18037           h1=h_base(f1,hd1)
18038           h2=h_base(f2,hd2)
18039           eij=ssm*h1+Ht*h2
18040           delta_inv=1.0d0/(xm-ssxm)
18041           deltasq_inv=delta_inv*delta_inv
18042           fac=ssm*hd1-Ht*hd2
18043           fac1=deltasq_inv*fac*(xm-rij)
18044           fac2=deltasq_inv*fac*(rij-ssxm)
18045           ed=delta_inv*(Ht*hd2-ssm*hd1)
18046           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18047           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18048           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18049         else
18050           havebond=.false.
18051           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18052           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18053           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18054           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18055                alf12/eps3rt)
18056           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18057           f1=(rij-ljxm)/(xm-ljxm)
18058           f2=(rij-xm)/(ljxm-xm)
18059           h1=h_base(f1,hd1)
18060           h2=h_base(f2,hd2)
18061           eij=Ht*h1+ljm*h2
18062           delta_inv=1.0d0/(ljxm-xm)
18063           deltasq_inv=delta_inv*delta_inv
18064           fac=Ht*hd1-ljm*hd2
18065           fac1=deltasq_inv*fac*(ljxm-rij)
18066           fac2=deltasq_inv*fac*(rij-xm)
18067           ed=delta_inv*(ljm*hd2-Ht*hd1)
18068           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18069           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18070           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18071         endif
18072 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18073
18074 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18075 !$$$        ssd=rij-ssXs
18076 !$$$        ljd=rij-ljXs
18077 !$$$        fac1=rij-ljxm
18078 !$$$        fac2=rij-ssxm
18079 !$$$
18080 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18081 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18082 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18083 !$$$
18084 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18085 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18086 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18087 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18088 !$$$        d_ssm(3)=omega
18089 !$$$
18090 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18091 !$$$        do k=1,3
18092 !$$$          d_ljm(k)=ljm*d_ljB(k)
18093 !$$$        enddo
18094 !$$$        ljm=ljm*ljB
18095 !$$$
18096 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18097 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18098 !$$$        d_ss(2)=akct*ssd
18099 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18100 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18101 !$$$        d_ss(3)=omega
18102 !$$$
18103 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18104 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18105 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18106 !$$$        do k=1,3
18107 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18108 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18109 !$$$        enddo
18110 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18111 !$$$
18112 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18113 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18114 !$$$        h1=h_base(f1,hd1)
18115 !$$$        h2=h_base(f2,hd2)
18116 !$$$        eij=ss*h1+ljf*h2
18117 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18118 !$$$        deltasq_inv=delta_inv*delta_inv
18119 !$$$        fac=ljf*hd2-ss*hd1
18120 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18121 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18122 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18123 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18124 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18125 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18126 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18127 !$$$
18128 !$$$        havebond=.false.
18129 !$$$        if (ed.gt.0.0d0) havebond=.true.
18130 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18131
18132       endif
18133
18134       if (havebond) then
18135 !#ifndef CLUST
18136 !#ifndef WHAM
18137 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18138 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18139 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18140 !        endif
18141 !#endif
18142 !#endif
18143         dyn_ssbond_ij(i,j)=eij
18144       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18145         dyn_ssbond_ij(i,j)=1.0d300
18146 !#ifndef CLUST
18147 !#ifndef WHAM
18148 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18149 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18150 !#endif
18151 !#endif
18152       endif
18153
18154 !-------TESTING CODE
18155 !el      if (checkstop) then
18156         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18157              "CHECKSTOP",rij,eij,ed
18158         echeck(jcheck)=eij
18159 !el      endif
18160       enddo
18161       if (checkstop) then
18162         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18163       endif
18164       enddo
18165       if (checkstop) then
18166         transgrad=.true.
18167         checkstop=.false.
18168       endif
18169 !-------END TESTING CODE
18170
18171       do k=1,3
18172         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18173         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18174       enddo
18175       do k=1,3
18176         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18177       enddo
18178       do k=1,3
18179         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18180              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18181              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18182         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18183              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18184              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18185       enddo
18186 !grad      do k=i,j-1
18187 !grad        do l=1,3
18188 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18189 !grad        enddo
18190 !grad      enddo
18191
18192       do l=1,3
18193         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18194         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18195       enddo
18196
18197       return
18198       end subroutine dyn_ssbond_ene
18199 !--------------------------------------------------------------------------
18200          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18201 !      implicit none
18202 !      Includes
18203       use calc_data
18204       use comm_sschecks
18205 !      include 'DIMENSIONS'
18206 !      include 'COMMON.SBRIDGE'
18207 !      include 'COMMON.CHAIN'
18208 !      include 'COMMON.DERIV'
18209 !      include 'COMMON.LOCAL'
18210 !      include 'COMMON.INTERACT'
18211 !      include 'COMMON.VAR'
18212 !      include 'COMMON.IOUNITS'
18213 !      include 'COMMON.CALC'
18214 #ifndef CLUST
18215 #ifndef WHAM
18216        use MD_data
18217 !      include 'COMMON.MD'
18218 !      use MD, only: totT,t_bath
18219 #endif
18220 #endif
18221       double precision h_base
18222       external h_base
18223
18224 !c     Input arguments
18225       integer resi,resj,resk,m,itypi,itypj,itypk
18226
18227 !c     Output arguments
18228       double precision eij,eij1,eij2,eij3
18229
18230 !c     Local variables
18231       logical havebond
18232 !c      integer itypi,itypj,k,l
18233       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18234       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18235       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18236       double precision sig0ij,ljd,sig,fac,e1,e2
18237       double precision dcosom1(3),dcosom2(3),ed
18238       double precision pom1,pom2
18239       double precision ljA,ljB,ljXs
18240       double precision d_ljB(1:3)
18241       double precision ssA,ssB,ssC,ssXs
18242       double precision ssxm,ljxm,ssm,ljm
18243       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18244       eij=0.0
18245       if (dtriss.eq.0) return
18246       i=resi
18247       j=resj
18248       k=resk
18249 !C      write(iout,*) resi,resj,resk
18250       itypi=itype(i,1)
18251       dxi=dc_norm(1,nres+i)
18252       dyi=dc_norm(2,nres+i)
18253       dzi=dc_norm(3,nres+i)
18254       dsci_inv=vbld_inv(i+nres)
18255       xi=c(1,nres+i)
18256       yi=c(2,nres+i)
18257       zi=c(3,nres+i)
18258       itypj=itype(j,1)
18259       xj=c(1,nres+j)
18260       yj=c(2,nres+j)
18261       zj=c(3,nres+j)
18262
18263       dxj=dc_norm(1,nres+j)
18264       dyj=dc_norm(2,nres+j)
18265       dzj=dc_norm(3,nres+j)
18266       dscj_inv=vbld_inv(j+nres)
18267       itypk=itype(k,1)
18268       xk=c(1,nres+k)
18269       yk=c(2,nres+k)
18270       zk=c(3,nres+k)
18271
18272       dxk=dc_norm(1,nres+k)
18273       dyk=dc_norm(2,nres+k)
18274       dzk=dc_norm(3,nres+k)
18275       dscj_inv=vbld_inv(k+nres)
18276       xij=xj-xi
18277       xik=xk-xi
18278       xjk=xk-xj
18279       yij=yj-yi
18280       yik=yk-yi
18281       yjk=yk-yj
18282       zij=zj-zi
18283       zik=zk-zi
18284       zjk=zk-zj
18285       rrij=(xij*xij+yij*yij+zij*zij)
18286       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18287       rrik=(xik*xik+yik*yik+zik*zik)
18288       rik=dsqrt(rrik)
18289       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18290       rjk=dsqrt(rrjk)
18291 !C there are three combination of distances for each trisulfide bonds
18292 !C The first case the ith atom is the center
18293 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18294 !C distance y is second distance the a,b,c,d are parameters derived for
18295 !C this problem d parameter was set as a penalty currenlty set to 1.
18296       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18297       eij1=0.0d0
18298       else
18299       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18300       endif
18301 !C second case jth atom is center
18302       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18303       eij2=0.0d0
18304       else
18305       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18306       endif
18307 !C the third case kth atom is the center
18308       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18309       eij3=0.0d0
18310       else
18311       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18312       endif
18313 !C      eij2=0.0
18314 !C      eij3=0.0
18315 !C      eij1=0.0
18316       eij=eij1+eij2+eij3
18317 !C      write(iout,*)i,j,k,eij
18318 !C The energy penalty calculated now time for the gradient part
18319 !C derivative over rij
18320       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18321       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18322             gg(1)=xij*fac/rij
18323             gg(2)=yij*fac/rij
18324             gg(3)=zij*fac/rij
18325       do m=1,3
18326         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18327         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18328       enddo
18329
18330       do l=1,3
18331         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18332         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18333       enddo
18334 !C now derivative over rik
18335       fac=-eij1**2/dtriss* &
18336       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18337       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18338             gg(1)=xik*fac/rik
18339             gg(2)=yik*fac/rik
18340             gg(3)=zik*fac/rik
18341       do m=1,3
18342         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18343         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18344       enddo
18345       do l=1,3
18346         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18347         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18348       enddo
18349 !C now derivative over rjk
18350       fac=-eij2**2/dtriss* &
18351       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18352       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18353             gg(1)=xjk*fac/rjk
18354             gg(2)=yjk*fac/rjk
18355             gg(3)=zjk*fac/rjk
18356       do m=1,3
18357         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18358         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18359       enddo
18360       do l=1,3
18361         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18362         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18363       enddo
18364       return
18365       end subroutine triple_ssbond_ene
18366
18367
18368
18369 !-----------------------------------------------------------------------------
18370       real(kind=8) function h_base(x,deriv)
18371 !     A smooth function going 0->1 in range [0,1]
18372 !     It should NOT be called outside range [0,1], it will not work there.
18373       implicit none
18374
18375 !     Input arguments
18376       real(kind=8) :: x
18377
18378 !     Output arguments
18379       real(kind=8) :: deriv
18380
18381 !     Local variables
18382       real(kind=8) :: xsq
18383
18384
18385 !     Two parabolas put together.  First derivative zero at extrema
18386 !$$$      if (x.lt.0.5D0) then
18387 !$$$        h_base=2.0D0*x*x
18388 !$$$        deriv=4.0D0*x
18389 !$$$      else
18390 !$$$        deriv=1.0D0-x
18391 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18392 !$$$        deriv=4.0D0*deriv
18393 !$$$      endif
18394
18395 !     Third degree polynomial.  First derivative zero at extrema
18396       h_base=x*x*(3.0d0-2.0d0*x)
18397       deriv=6.0d0*x*(1.0d0-x)
18398
18399 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18400 !$$$      xsq=x*x
18401 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18402 !$$$      deriv=x-1.0d0
18403 !$$$      deriv=deriv*deriv
18404 !$$$      deriv=30.0d0*xsq*deriv
18405
18406       return
18407       end function h_base
18408 !-----------------------------------------------------------------------------
18409       subroutine dyn_set_nss
18410 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18411 !      implicit none
18412       use MD_data, only: totT,t_bath
18413 !     Includes
18414 !      include 'DIMENSIONS'
18415 #ifdef MPI
18416       include "mpif.h"
18417 #endif
18418 !      include 'COMMON.SBRIDGE'
18419 !      include 'COMMON.CHAIN'
18420 !      include 'COMMON.IOUNITS'
18421 !      include 'COMMON.SETUP'
18422 !      include 'COMMON.MD'
18423 !     Local variables
18424       real(kind=8) :: emin
18425       integer :: i,j,imin,ierr
18426       integer :: diff,allnss,newnss
18427       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18428                 newihpb,newjhpb
18429       logical :: found
18430       integer,dimension(0:nfgtasks) :: i_newnss
18431       integer,dimension(0:nfgtasks) :: displ
18432       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18433       integer :: g_newnss
18434
18435       allnss=0
18436       do i=1,nres-1
18437         do j=i+1,nres
18438           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18439             allnss=allnss+1
18440             allflag(allnss)=0
18441             allihpb(allnss)=i
18442             alljhpb(allnss)=j
18443           endif
18444         enddo
18445       enddo
18446
18447 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18448
18449  1    emin=1.0d300
18450       do i=1,allnss
18451         if (allflag(i).eq.0 .and. &
18452              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18453           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18454           imin=i
18455         endif
18456       enddo
18457       if (emin.lt.1.0d300) then
18458         allflag(imin)=1
18459         do i=1,allnss
18460           if (allflag(i).eq.0 .and. &
18461                (allihpb(i).eq.allihpb(imin) .or. &
18462                alljhpb(i).eq.allihpb(imin) .or. &
18463                allihpb(i).eq.alljhpb(imin) .or. &
18464                alljhpb(i).eq.alljhpb(imin))) then
18465             allflag(i)=-1
18466           endif
18467         enddo
18468         goto 1
18469       endif
18470
18471 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18472
18473       newnss=0
18474       do i=1,allnss
18475         if (allflag(i).eq.1) then
18476           newnss=newnss+1
18477           newihpb(newnss)=allihpb(i)
18478           newjhpb(newnss)=alljhpb(i)
18479         endif
18480       enddo
18481
18482 #ifdef MPI
18483       if (nfgtasks.gt.1)then
18484
18485         call MPI_Reduce(newnss,g_newnss,1,&
18486           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18487         call MPI_Gather(newnss,1,MPI_INTEGER,&
18488                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18489         displ(0)=0
18490         do i=1,nfgtasks-1,1
18491           displ(i)=i_newnss(i-1)+displ(i-1)
18492         enddo
18493         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18494                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18495                          king,FG_COMM,IERR)
18496         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18497                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18498                          king,FG_COMM,IERR)
18499         if(fg_rank.eq.0) then
18500 !         print *,'g_newnss',g_newnss
18501 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18502 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18503          newnss=g_newnss
18504          do i=1,newnss
18505           newihpb(i)=g_newihpb(i)
18506           newjhpb(i)=g_newjhpb(i)
18507          enddo
18508         endif
18509       endif
18510 #endif
18511
18512       diff=newnss-nss
18513
18514 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18515 !       print *,newnss,nss,maxdim
18516       do i=1,nss
18517         found=.false.
18518 !        print *,newnss
18519         do j=1,newnss
18520 !!          print *,j
18521           if (idssb(i).eq.newihpb(j) .and. &
18522                jdssb(i).eq.newjhpb(j)) found=.true.
18523         enddo
18524 #ifndef CLUST
18525 #ifndef WHAM
18526 !        write(iout,*) "found",found,i,j
18527         if (.not.found.and.fg_rank.eq.0) &
18528             write(iout,'(a15,f12.2,f8.1,2i5)') &
18529              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18530 #endif
18531 #endif
18532       enddo
18533
18534       do i=1,newnss
18535         found=.false.
18536         do j=1,nss
18537 !          print *,i,j
18538           if (newihpb(i).eq.idssb(j) .and. &
18539                newjhpb(i).eq.jdssb(j)) found=.true.
18540         enddo
18541 #ifndef CLUST
18542 #ifndef WHAM
18543 !        write(iout,*) "found",found,i,j
18544         if (.not.found.and.fg_rank.eq.0) &
18545             write(iout,'(a15,f12.2,f8.1,2i5)') &
18546              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18547 #endif
18548 #endif
18549       enddo
18550
18551       nss=newnss
18552       do i=1,nss
18553         idssb(i)=newihpb(i)
18554         jdssb(i)=newjhpb(i)
18555       enddo
18556
18557       return
18558       end subroutine dyn_set_nss
18559 ! Lipid transfer energy function
18560       subroutine Eliptransfer(eliptran)
18561 !C this is done by Adasko
18562 !C      print *,"wchodze"
18563 !C structure of box:
18564 !C      water
18565 !C--bordliptop-- buffore starts
18566 !C--bufliptop--- here true lipid starts
18567 !C      lipid
18568 !C--buflipbot--- lipid ends buffore starts
18569 !C--bordlipbot--buffore ends
18570       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18571       integer :: i
18572       eliptran=0.0
18573 !      print *, "I am in eliptran"
18574       do i=ilip_start,ilip_end
18575 !C       do i=1,1
18576         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18577          cycle
18578
18579         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18580         if (positi.le.0.0) positi=positi+boxzsize
18581 !C        print *,i
18582 !C first for peptide groups
18583 !c for each residue check if it is in lipid or lipid water border area
18584        if ((positi.gt.bordlipbot)  &
18585       .and.(positi.lt.bordliptop)) then
18586 !C the energy transfer exist
18587         if (positi.lt.buflipbot) then
18588 !C what fraction I am in
18589          fracinbuf=1.0d0-      &
18590              ((positi-bordlipbot)/lipbufthick)
18591 !C lipbufthick is thickenes of lipid buffore
18592          sslip=sscalelip(fracinbuf)
18593          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18594          eliptran=eliptran+sslip*pepliptran
18595          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18596          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18597 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18598
18599 !C        print *,"doing sccale for lower part"
18600 !C         print *,i,sslip,fracinbuf,ssgradlip
18601         elseif (positi.gt.bufliptop) then
18602          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18603          sslip=sscalelip(fracinbuf)
18604          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18605          eliptran=eliptran+sslip*pepliptran
18606          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18607          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18608 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18609 !C          print *, "doing sscalefor top part"
18610 !C         print *,i,sslip,fracinbuf,ssgradlip
18611         else
18612          eliptran=eliptran+pepliptran
18613 !C         print *,"I am in true lipid"
18614         endif
18615 !C       else
18616 !C       eliptran=elpitran+0.0 ! I am in water
18617        endif
18618        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18619        enddo
18620 ! here starts the side chain transfer
18621        do i=ilip_start,ilip_end
18622         if (itype(i,1).eq.ntyp1) cycle
18623         positi=(mod(c(3,i+nres),boxzsize))
18624         if (positi.le.0) positi=positi+boxzsize
18625 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18626 !c for each residue check if it is in lipid or lipid water border area
18627 !C       respos=mod(c(3,i+nres),boxzsize)
18628 !C       print *,positi,bordlipbot,buflipbot
18629        if ((positi.gt.bordlipbot) &
18630        .and.(positi.lt.bordliptop)) then
18631 !C the energy transfer exist
18632         if (positi.lt.buflipbot) then
18633          fracinbuf=1.0d0-   &
18634            ((positi-bordlipbot)/lipbufthick)
18635 !C lipbufthick is thickenes of lipid buffore
18636          sslip=sscalelip(fracinbuf)
18637          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18638          eliptran=eliptran+sslip*liptranene(itype(i,1))
18639          gliptranx(3,i)=gliptranx(3,i) &
18640       +ssgradlip*liptranene(itype(i,1))
18641          gliptranc(3,i-1)= gliptranc(3,i-1) &
18642       +ssgradlip*liptranene(itype(i,1))
18643 !C         print *,"doing sccale for lower part"
18644         elseif (positi.gt.bufliptop) then
18645          fracinbuf=1.0d0-  &
18646       ((bordliptop-positi)/lipbufthick)
18647          sslip=sscalelip(fracinbuf)
18648          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18649          eliptran=eliptran+sslip*liptranene(itype(i,1))
18650          gliptranx(3,i)=gliptranx(3,i)  &
18651        +ssgradlip*liptranene(itype(i,1))
18652          gliptranc(3,i-1)= gliptranc(3,i-1) &
18653       +ssgradlip*liptranene(itype(i,1))
18654 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18655         else
18656          eliptran=eliptran+liptranene(itype(i,1))
18657 !C         print *,"I am in true lipid"
18658         endif
18659         endif ! if in lipid or buffor
18660 !C       else
18661 !C       eliptran=elpitran+0.0 ! I am in water
18662         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18663        enddo
18664        return
18665        end  subroutine Eliptransfer
18666 !----------------------------------NANO FUNCTIONS
18667 !C-----------------------------------------------------------------------
18668 !C-----------------------------------------------------------
18669 !C This subroutine is to mimic the histone like structure but as well can be
18670 !C utilizet to nanostructures (infinit) small modification has to be used to
18671 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18672 !C gradient has to be modified at the ends
18673 !C The energy function is Kihara potential
18674 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18675 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18676 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18677 !C simple Kihara potential
18678       subroutine calctube(Etube)
18679       real(kind=8),dimension(3) :: vectube
18680       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18681        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18682        sc_aa_tube,sc_bb_tube
18683       integer :: i,j,iti
18684       Etube=0.0d0
18685       do i=itube_start,itube_end
18686         enetube(i)=0.0d0
18687         enetube(i+nres)=0.0d0
18688       enddo
18689 !C first we calculate the distance from tube center
18690 !C for UNRES
18691        do i=itube_start,itube_end
18692 !C lets ommit dummy atoms for now
18693        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18694 !C now calculate distance from center of tube and direction vectors
18695       xmin=boxxsize
18696       ymin=boxysize
18697 ! Find minimum distance in periodic box
18698         do j=-1,1
18699          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18700          vectube(1)=vectube(1)+boxxsize*j
18701          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18702          vectube(2)=vectube(2)+boxysize*j
18703          xminact=abs(vectube(1)-tubecenter(1))
18704          yminact=abs(vectube(2)-tubecenter(2))
18705            if (xmin.gt.xminact) then
18706             xmin=xminact
18707             xtemp=vectube(1)
18708            endif
18709            if (ymin.gt.yminact) then
18710              ymin=yminact
18711              ytemp=vectube(2)
18712             endif
18713          enddo
18714       vectube(1)=xtemp
18715       vectube(2)=ytemp
18716       vectube(1)=vectube(1)-tubecenter(1)
18717       vectube(2)=vectube(2)-tubecenter(2)
18718
18719 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18720 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18721
18722 !C as the tube is infinity we do not calculate the Z-vector use of Z
18723 !C as chosen axis
18724       vectube(3)=0.0d0
18725 !C now calculte the distance
18726        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18727 !C now normalize vector
18728       vectube(1)=vectube(1)/tub_r
18729       vectube(2)=vectube(2)/tub_r
18730 !C calculte rdiffrence between r and r0
18731       rdiff=tub_r-tubeR0
18732 !C and its 6 power
18733       rdiff6=rdiff**6.0d0
18734 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18735        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18736 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18737 !C       print *,rdiff,rdiff6,pep_aa_tube
18738 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18739 !C now we calculate gradient
18740        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18741             6.0d0*pep_bb_tube)/rdiff6/rdiff
18742 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18743 !C     &rdiff,fac
18744 !C now direction of gg_tube vector
18745         do j=1,3
18746         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18747         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18748         enddo
18749         enddo
18750 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18751 !C        print *,gg_tube(1,0),"TU"
18752
18753
18754        do i=itube_start,itube_end
18755 !C Lets not jump over memory as we use many times iti
18756          iti=itype(i,1)
18757 !C lets ommit dummy atoms for now
18758          if ((iti.eq.ntyp1)  &
18759 !C in UNRES uncomment the line below as GLY has no side-chain...
18760 !C      .or.(iti.eq.10)
18761         ) cycle
18762       xmin=boxxsize
18763       ymin=boxysize
18764         do j=-1,1
18765          vectube(1)=mod((c(1,i+nres)),boxxsize)
18766          vectube(1)=vectube(1)+boxxsize*j
18767          vectube(2)=mod((c(2,i+nres)),boxysize)
18768          vectube(2)=vectube(2)+boxysize*j
18769
18770          xminact=abs(vectube(1)-tubecenter(1))
18771          yminact=abs(vectube(2)-tubecenter(2))
18772            if (xmin.gt.xminact) then
18773             xmin=xminact
18774             xtemp=vectube(1)
18775            endif
18776            if (ymin.gt.yminact) then
18777              ymin=yminact
18778              ytemp=vectube(2)
18779             endif
18780          enddo
18781       vectube(1)=xtemp
18782       vectube(2)=ytemp
18783 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18784 !C     &     tubecenter(2)
18785       vectube(1)=vectube(1)-tubecenter(1)
18786       vectube(2)=vectube(2)-tubecenter(2)
18787
18788 !C as the tube is infinity we do not calculate the Z-vector use of Z
18789 !C as chosen axis
18790       vectube(3)=0.0d0
18791 !C now calculte the distance
18792        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18793 !C now normalize vector
18794       vectube(1)=vectube(1)/tub_r
18795       vectube(2)=vectube(2)/tub_r
18796
18797 !C calculte rdiffrence between r and r0
18798       rdiff=tub_r-tubeR0
18799 !C and its 6 power
18800       rdiff6=rdiff**6.0d0
18801 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18802        sc_aa_tube=sc_aa_tube_par(iti)
18803        sc_bb_tube=sc_bb_tube_par(iti)
18804        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18805        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18806              6.0d0*sc_bb_tube/rdiff6/rdiff
18807 !C now direction of gg_tube vector
18808          do j=1,3
18809           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18810           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18811          enddo
18812         enddo
18813         do i=itube_start,itube_end
18814           Etube=Etube+enetube(i)+enetube(i+nres)
18815         enddo
18816 !C        print *,"ETUBE", etube
18817         return
18818         end subroutine calctube
18819 !C TO DO 1) add to total energy
18820 !C       2) add to gradient summation
18821 !C       3) add reading parameters (AND of course oppening of PARAM file)
18822 !C       4) add reading the center of tube
18823 !C       5) add COMMONs
18824 !C       6) add to zerograd
18825 !C       7) allocate matrices
18826
18827
18828 !C-----------------------------------------------------------------------
18829 !C-----------------------------------------------------------
18830 !C This subroutine is to mimic the histone like structure but as well can be
18831 !C utilizet to nanostructures (infinit) small modification has to be used to
18832 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18833 !C gradient has to be modified at the ends
18834 !C The energy function is Kihara potential
18835 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18836 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18837 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18838 !C simple Kihara potential
18839       subroutine calctube2(Etube)
18840             real(kind=8),dimension(3) :: vectube
18841       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18842        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18843        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18844       integer:: i,j,iti
18845       Etube=0.0d0
18846       do i=itube_start,itube_end
18847         enetube(i)=0.0d0
18848         enetube(i+nres)=0.0d0
18849       enddo
18850 !C first we calculate the distance from tube center
18851 !C first sugare-phosphate group for NARES this would be peptide group
18852 !C for UNRES
18853        do i=itube_start,itube_end
18854 !C lets ommit dummy atoms for now
18855
18856        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18857 !C now calculate distance from center of tube and direction vectors
18858 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18859 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18860 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18861 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18862       xmin=boxxsize
18863       ymin=boxysize
18864         do j=-1,1
18865          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18866          vectube(1)=vectube(1)+boxxsize*j
18867          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18868          vectube(2)=vectube(2)+boxysize*j
18869
18870          xminact=abs(vectube(1)-tubecenter(1))
18871          yminact=abs(vectube(2)-tubecenter(2))
18872            if (xmin.gt.xminact) then
18873             xmin=xminact
18874             xtemp=vectube(1)
18875            endif
18876            if (ymin.gt.yminact) then
18877              ymin=yminact
18878              ytemp=vectube(2)
18879             endif
18880          enddo
18881       vectube(1)=xtemp
18882       vectube(2)=ytemp
18883       vectube(1)=vectube(1)-tubecenter(1)
18884       vectube(2)=vectube(2)-tubecenter(2)
18885
18886 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18887 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18888
18889 !C as the tube is infinity we do not calculate the Z-vector use of Z
18890 !C as chosen axis
18891       vectube(3)=0.0d0
18892 !C now calculte the distance
18893        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18894 !C now normalize vector
18895       vectube(1)=vectube(1)/tub_r
18896       vectube(2)=vectube(2)/tub_r
18897 !C calculte rdiffrence between r and r0
18898       rdiff=tub_r-tubeR0
18899 !C and its 6 power
18900       rdiff6=rdiff**6.0d0
18901 !C THIS FRAGMENT MAKES TUBE FINITE
18902         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18903         if (positi.le.0) positi=positi+boxzsize
18904 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18905 !c for each residue check if it is in lipid or lipid water border area
18906 !C       respos=mod(c(3,i+nres),boxzsize)
18907 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18908        if ((positi.gt.bordtubebot)  &
18909         .and.(positi.lt.bordtubetop)) then
18910 !C the energy transfer exist
18911         if (positi.lt.buftubebot) then
18912          fracinbuf=1.0d0-  &
18913            ((positi-bordtubebot)/tubebufthick)
18914 !C lipbufthick is thickenes of lipid buffore
18915          sstube=sscalelip(fracinbuf)
18916          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18917 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18918          enetube(i)=enetube(i)+sstube*tubetranenepep
18919 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18920 !C     &+ssgradtube*tubetranene(itype(i,1))
18921 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18922 !C     &+ssgradtube*tubetranene(itype(i,1))
18923 !C         print *,"doing sccale for lower part"
18924         elseif (positi.gt.buftubetop) then
18925          fracinbuf=1.0d0-  &
18926         ((bordtubetop-positi)/tubebufthick)
18927          sstube=sscalelip(fracinbuf)
18928          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18929          enetube(i)=enetube(i)+sstube*tubetranenepep
18930 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18931 !C     &+ssgradtube*tubetranene(itype(i,1))
18932 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18933 !C     &+ssgradtube*tubetranene(itype(i,1))
18934 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18935         else
18936          sstube=1.0d0
18937          ssgradtube=0.0d0
18938          enetube(i)=enetube(i)+sstube*tubetranenepep
18939 !C         print *,"I am in true lipid"
18940         endif
18941         else
18942 !C          sstube=0.0d0
18943 !C          ssgradtube=0.0d0
18944         cycle
18945         endif ! if in lipid or buffor
18946
18947 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18948        enetube(i)=enetube(i)+sstube* &
18949         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18950 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18951 !C       print *,rdiff,rdiff6,pep_aa_tube
18952 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18953 !C now we calculate gradient
18954        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
18955              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
18956 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18957 !C     &rdiff,fac
18958
18959 !C now direction of gg_tube vector
18960        do j=1,3
18961         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18962         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18963         enddo
18964          gg_tube(3,i)=gg_tube(3,i)  &
18965        +ssgradtube*enetube(i)/sstube/2.0d0
18966          gg_tube(3,i-1)= gg_tube(3,i-1)  &
18967        +ssgradtube*enetube(i)/sstube/2.0d0
18968
18969         enddo
18970 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18971 !C        print *,gg_tube(1,0),"TU"
18972         do i=itube_start,itube_end
18973 !C Lets not jump over memory as we use many times iti
18974          iti=itype(i,1)
18975 !C lets ommit dummy atoms for now
18976          if ((iti.eq.ntyp1) &
18977 !!C in UNRES uncomment the line below as GLY has no side-chain...
18978            .or.(iti.eq.10) &
18979           ) cycle
18980           vectube(1)=c(1,i+nres)
18981           vectube(1)=mod(vectube(1),boxxsize)
18982           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18983           vectube(2)=c(2,i+nres)
18984           vectube(2)=mod(vectube(2),boxysize)
18985           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18986
18987       vectube(1)=vectube(1)-tubecenter(1)
18988       vectube(2)=vectube(2)-tubecenter(2)
18989 !C THIS FRAGMENT MAKES TUBE FINITE
18990         positi=(mod(c(3,i+nres),boxzsize))
18991         if (positi.le.0) positi=positi+boxzsize
18992 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18993 !c for each residue check if it is in lipid or lipid water border area
18994 !C       respos=mod(c(3,i+nres),boxzsize)
18995 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18996
18997        if ((positi.gt.bordtubebot)  &
18998         .and.(positi.lt.bordtubetop)) then
18999 !C the energy transfer exist
19000         if (positi.lt.buftubebot) then
19001          fracinbuf=1.0d0- &
19002             ((positi-bordtubebot)/tubebufthick)
19003 !C lipbufthick is thickenes of lipid buffore
19004          sstube=sscalelip(fracinbuf)
19005          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19006 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19007          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19008 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19009 !C     &+ssgradtube*tubetranene(itype(i,1))
19010 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19011 !C     &+ssgradtube*tubetranene(itype(i,1))
19012 !C         print *,"doing sccale for lower part"
19013         elseif (positi.gt.buftubetop) then
19014          fracinbuf=1.0d0- &
19015         ((bordtubetop-positi)/tubebufthick)
19016
19017          sstube=sscalelip(fracinbuf)
19018          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19019          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19020 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19021 !C     &+ssgradtube*tubetranene(itype(i,1))
19022 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19023 !C     &+ssgradtube*tubetranene(itype(i,1))
19024 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19025         else
19026          sstube=1.0d0
19027          ssgradtube=0.0d0
19028          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19029 !C         print *,"I am in true lipid"
19030         endif
19031         else
19032 !C          sstube=0.0d0
19033 !C          ssgradtube=0.0d0
19034         cycle
19035         endif ! if in lipid or buffor
19036 !CEND OF FINITE FRAGMENT
19037 !C as the tube is infinity we do not calculate the Z-vector use of Z
19038 !C as chosen axis
19039       vectube(3)=0.0d0
19040 !C now calculte the distance
19041        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19042 !C now normalize vector
19043       vectube(1)=vectube(1)/tub_r
19044       vectube(2)=vectube(2)/tub_r
19045 !C calculte rdiffrence between r and r0
19046       rdiff=tub_r-tubeR0
19047 !C and its 6 power
19048       rdiff6=rdiff**6.0d0
19049 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19050        sc_aa_tube=sc_aa_tube_par(iti)
19051        sc_bb_tube=sc_bb_tube_par(iti)
19052        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19053                        *sstube+enetube(i+nres)
19054 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19055 !C now we calculate gradient
19056        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19057             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19058 !C now direction of gg_tube vector
19059          do j=1,3
19060           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19061           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19062          enddo
19063          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19064        +ssgradtube*enetube(i+nres)/sstube
19065          gg_tube(3,i-1)= gg_tube(3,i-1) &
19066        +ssgradtube*enetube(i+nres)/sstube
19067
19068         enddo
19069         do i=itube_start,itube_end
19070           Etube=Etube+enetube(i)+enetube(i+nres)
19071         enddo
19072 !C        print *,"ETUBE", etube
19073         return
19074         end subroutine calctube2
19075 !=====================================================================================================================================
19076       subroutine calcnano(Etube)
19077       real(kind=8),dimension(3) :: vectube
19078
19079       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19080        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19081        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19082        integer:: i,j,iti,r
19083
19084       Etube=0.0d0
19085 !      print *,itube_start,itube_end,"poczatek"
19086       do i=itube_start,itube_end
19087         enetube(i)=0.0d0
19088         enetube(i+nres)=0.0d0
19089       enddo
19090 !C first we calculate the distance from tube center
19091 !C first sugare-phosphate group for NARES this would be peptide group
19092 !C for UNRES
19093        do i=itube_start,itube_end
19094 !C lets ommit dummy atoms for now
19095        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19096 !C now calculate distance from center of tube and direction vectors
19097       xmin=boxxsize
19098       ymin=boxysize
19099       zmin=boxzsize
19100
19101         do j=-1,1
19102          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19103          vectube(1)=vectube(1)+boxxsize*j
19104          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19105          vectube(2)=vectube(2)+boxysize*j
19106          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19107          vectube(3)=vectube(3)+boxzsize*j
19108
19109
19110          xminact=dabs(vectube(1)-tubecenter(1))
19111          yminact=dabs(vectube(2)-tubecenter(2))
19112          zminact=dabs(vectube(3)-tubecenter(3))
19113
19114            if (xmin.gt.xminact) then
19115             xmin=xminact
19116             xtemp=vectube(1)
19117            endif
19118            if (ymin.gt.yminact) then
19119              ymin=yminact
19120              ytemp=vectube(2)
19121             endif
19122            if (zmin.gt.zminact) then
19123              zmin=zminact
19124              ztemp=vectube(3)
19125             endif
19126          enddo
19127       vectube(1)=xtemp
19128       vectube(2)=ytemp
19129       vectube(3)=ztemp
19130
19131       vectube(1)=vectube(1)-tubecenter(1)
19132       vectube(2)=vectube(2)-tubecenter(2)
19133       vectube(3)=vectube(3)-tubecenter(3)
19134
19135 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19136 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19137 !C as the tube is infinity we do not calculate the Z-vector use of Z
19138 !C as chosen axis
19139 !C      vectube(3)=0.0d0
19140 !C now calculte the distance
19141        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19142 !C now normalize vector
19143       vectube(1)=vectube(1)/tub_r
19144       vectube(2)=vectube(2)/tub_r
19145       vectube(3)=vectube(3)/tub_r
19146 !C calculte rdiffrence between r and r0
19147       rdiff=tub_r-tubeR0
19148 !C and its 6 power
19149       rdiff6=rdiff**6.0d0
19150 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19151        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19152 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19153 !C       print *,rdiff,rdiff6,pep_aa_tube
19154 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19155 !C now we calculate gradient
19156        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19157             6.0d0*pep_bb_tube)/rdiff6/rdiff
19158 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19159 !C     &rdiff,fac
19160          if (acavtubpep.eq.0.0d0) then
19161 !C go to 667
19162          enecavtube(i)=0.0
19163          faccav=0.0
19164          else
19165          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19166          enecavtube(i)=  &
19167         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19168         /denominator
19169          enecavtube(i)=0.0
19170          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19171         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19172         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19173         /denominator**2.0d0
19174 !C         faccav=0.0
19175 !C         fac=fac+faccav
19176 !C 667     continue
19177          endif
19178           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19179         do j=1,3
19180         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19181         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19182         enddo
19183         enddo
19184
19185        do i=itube_start,itube_end
19186         enecavtube(i)=0.0d0
19187 !C Lets not jump over memory as we use many times iti
19188          iti=itype(i,1)
19189 !C lets ommit dummy atoms for now
19190          if ((iti.eq.ntyp1) &
19191 !C in UNRES uncomment the line below as GLY has no side-chain...
19192 !C      .or.(iti.eq.10)
19193          ) cycle
19194       xmin=boxxsize
19195       ymin=boxysize
19196       zmin=boxzsize
19197         do j=-1,1
19198          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19199          vectube(1)=vectube(1)+boxxsize*j
19200          vectube(2)=dmod((c(2,i+nres)),boxysize)
19201          vectube(2)=vectube(2)+boxysize*j
19202          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19203          vectube(3)=vectube(3)+boxzsize*j
19204
19205
19206          xminact=dabs(vectube(1)-tubecenter(1))
19207          yminact=dabs(vectube(2)-tubecenter(2))
19208          zminact=dabs(vectube(3)-tubecenter(3))
19209
19210            if (xmin.gt.xminact) then
19211             xmin=xminact
19212             xtemp=vectube(1)
19213            endif
19214            if (ymin.gt.yminact) then
19215              ymin=yminact
19216              ytemp=vectube(2)
19217             endif
19218            if (zmin.gt.zminact) then
19219              zmin=zminact
19220              ztemp=vectube(3)
19221             endif
19222          enddo
19223       vectube(1)=xtemp
19224       vectube(2)=ytemp
19225       vectube(3)=ztemp
19226
19227 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19228 !C     &     tubecenter(2)
19229       vectube(1)=vectube(1)-tubecenter(1)
19230       vectube(2)=vectube(2)-tubecenter(2)
19231       vectube(3)=vectube(3)-tubecenter(3)
19232 !C now calculte the distance
19233        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19234 !C now normalize vector
19235       vectube(1)=vectube(1)/tub_r
19236       vectube(2)=vectube(2)/tub_r
19237       vectube(3)=vectube(3)/tub_r
19238
19239 !C calculte rdiffrence between r and r0
19240       rdiff=tub_r-tubeR0
19241 !C and its 6 power
19242       rdiff6=rdiff**6.0d0
19243        sc_aa_tube=sc_aa_tube_par(iti)
19244        sc_bb_tube=sc_bb_tube_par(iti)
19245        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19246 !C       enetube(i+nres)=0.0d0
19247 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19248 !C now we calculate gradient
19249        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19250             6.0d0*sc_bb_tube/rdiff6/rdiff
19251 !C       fac=0.0
19252 !C now direction of gg_tube vector
19253 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19254          if (acavtub(iti).eq.0.0d0) then
19255 !C go to 667
19256          enecavtube(i+nres)=0.0d0
19257          faccav=0.0d0
19258          else
19259          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19260          enecavtube(i+nres)=   &
19261         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19262         /denominator
19263 !C         enecavtube(i)=0.0
19264          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19265         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19266         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19267         /denominator**2.0d0
19268 !C         faccav=0.0
19269          fac=fac+faccav
19270 !C 667     continue
19271          endif
19272 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19273 !C     &   enecavtube(i),faccav
19274 !C         print *,"licz=",
19275 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19276 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19277          do j=1,3
19278           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19279           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19280          enddo
19281           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19282         enddo
19283
19284
19285
19286         do i=itube_start,itube_end
19287           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19288          +enecavtube(i+nres)
19289         enddo
19290 !        do i=1,20
19291 !         print *,"begin", i,"a"
19292 !         do r=1,10000
19293 !          rdiff=r/100.0d0
19294 !          rdiff6=rdiff**6.0d0
19295 !          sc_aa_tube=sc_aa_tube_par(i)
19296 !          sc_bb_tube=sc_bb_tube_par(i)
19297 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19298 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19299 !          enecavtube(i)=   &
19300 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19301 !         /denominator
19302
19303 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19304 !         enddo
19305 !         print *,"end",i,"a"
19306 !        enddo
19307 !C        print *,"ETUBE", etube
19308         return
19309         end subroutine calcnano
19310
19311 !===============================================
19312 !--------------------------------------------------------------------------------
19313 !C first for shielding is setting of function of side-chains
19314
19315        subroutine set_shield_fac2
19316        real(kind=8) :: div77_81=0.974996043d0, &
19317         div4_81=0.2222222222d0
19318        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19319          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19320          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19321          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19322 !C the vector between center of side_chain and peptide group
19323        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19324          pept_group,costhet_grad,cosphi_grad_long, &
19325          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19326          sh_frac_dist_grad,pep_side
19327         integer i,j,k
19328 !C      write(2,*) "ivec",ivec_start,ivec_end
19329       do i=1,nres
19330         fac_shield(i)=0.0d0
19331         do j=1,3
19332         grad_shield(j,i)=0.0d0
19333         enddo
19334       enddo
19335       do i=ivec_start,ivec_end
19336 !C      do i=1,nres-1
19337 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19338       ishield_list(i)=0
19339       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19340 !Cif there two consequtive dummy atoms there is no peptide group between them
19341 !C the line below has to be changed for FGPROC>1
19342       VolumeTotal=0.0
19343       do k=1,nres
19344        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19345        dist_pep_side=0.0
19346        dist_side_calf=0.0
19347        do j=1,3
19348 !C first lets set vector conecting the ithe side-chain with kth side-chain
19349       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19350 !C      pep_side(j)=2.0d0
19351 !C and vector conecting the side-chain with its proper calfa
19352       side_calf(j)=c(j,k+nres)-c(j,k)
19353 !C      side_calf(j)=2.0d0
19354       pept_group(j)=c(j,i)-c(j,i+1)
19355 !C lets have their lenght
19356       dist_pep_side=pep_side(j)**2+dist_pep_side
19357       dist_side_calf=dist_side_calf+side_calf(j)**2
19358       dist_pept_group=dist_pept_group+pept_group(j)**2
19359       enddo
19360        dist_pep_side=sqrt(dist_pep_side)
19361        dist_pept_group=sqrt(dist_pept_group)
19362        dist_side_calf=sqrt(dist_side_calf)
19363       do j=1,3
19364         pep_side_norm(j)=pep_side(j)/dist_pep_side
19365         side_calf_norm(j)=dist_side_calf
19366       enddo
19367 !C now sscale fraction
19368        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19369 !C       print *,buff_shield,"buff"
19370 !C now sscale
19371         if (sh_frac_dist.le.0.0) cycle
19372 !C        print *,ishield_list(i),i
19373 !C If we reach here it means that this side chain reaches the shielding sphere
19374 !C Lets add him to the list for gradient
19375         ishield_list(i)=ishield_list(i)+1
19376 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19377 !C this list is essential otherwise problem would be O3
19378         shield_list(ishield_list(i),i)=k
19379 !C Lets have the sscale value
19380         if (sh_frac_dist.gt.1.0) then
19381          scale_fac_dist=1.0d0
19382          do j=1,3
19383          sh_frac_dist_grad(j)=0.0d0
19384          enddo
19385         else
19386          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19387                         *(2.0d0*sh_frac_dist-3.0d0)
19388          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19389                        /dist_pep_side/buff_shield*0.5d0
19390          do j=1,3
19391          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19392 !C         sh_frac_dist_grad(j)=0.0d0
19393 !C         scale_fac_dist=1.0d0
19394 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19395 !C     &                    sh_frac_dist_grad(j)
19396          enddo
19397         endif
19398 !C this is what is now we have the distance scaling now volume...
19399       short=short_r_sidechain(itype(k,1))
19400       long=long_r_sidechain(itype(k,1))
19401       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19402       sinthet=short/dist_pep_side*costhet
19403 !C now costhet_grad
19404 !C       costhet=0.6d0
19405 !C       sinthet=0.8
19406        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19407 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19408 !C     &             -short/dist_pep_side**2/costhet)
19409 !C       costhet_fac=0.0d0
19410        do j=1,3
19411          costhet_grad(j)=costhet_fac*pep_side(j)
19412        enddo
19413 !C remember for the final gradient multiply costhet_grad(j)
19414 !C for side_chain by factor -2 !
19415 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19416 !C pep_side0pept_group is vector multiplication
19417       pep_side0pept_group=0.0d0
19418       do j=1,3
19419       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19420       enddo
19421       cosalfa=(pep_side0pept_group/ &
19422       (dist_pep_side*dist_side_calf))
19423       fac_alfa_sin=1.0d0-cosalfa**2
19424       fac_alfa_sin=dsqrt(fac_alfa_sin)
19425       rkprim=fac_alfa_sin*(long-short)+short
19426 !C      rkprim=short
19427
19428 !C now costhet_grad
19429        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19430 !C       cosphi=0.6
19431        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19432        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19433            dist_pep_side**2)
19434 !C       sinphi=0.8
19435        do j=1,3
19436          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19437       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19438       *(long-short)/fac_alfa_sin*cosalfa/ &
19439       ((dist_pep_side*dist_side_calf))* &
19440       ((side_calf(j))-cosalfa* &
19441       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19442 !C       cosphi_grad_long(j)=0.0d0
19443         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19444       *(long-short)/fac_alfa_sin*cosalfa &
19445       /((dist_pep_side*dist_side_calf))* &
19446       (pep_side(j)- &
19447       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19448 !C       cosphi_grad_loc(j)=0.0d0
19449        enddo
19450 !C      print *,sinphi,sinthet
19451       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19452      &                    /VSolvSphere_div
19453 !C     &                    *wshield
19454 !C now the gradient...
19455       do j=1,3
19456       grad_shield(j,i)=grad_shield(j,i) &
19457 !C gradient po skalowaniu
19458                      +(sh_frac_dist_grad(j)*VofOverlap &
19459 !C  gradient po costhet
19460             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19461         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19462             sinphi/sinthet*costhet*costhet_grad(j) &
19463            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19464         )*wshield
19465 !C grad_shield_side is Cbeta sidechain gradient
19466       grad_shield_side(j,ishield_list(i),i)=&
19467              (sh_frac_dist_grad(j)*-2.0d0&
19468              *VofOverlap&
19469             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19470        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19471             sinphi/sinthet*costhet*costhet_grad(j)&
19472            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19473             )*wshield
19474
19475        grad_shield_loc(j,ishield_list(i),i)=   &
19476             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19477       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19478             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19479              ))&
19480              *wshield
19481       enddo
19482       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19483       enddo
19484       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19485
19486 !C      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19487       enddo
19488       return
19489       end subroutine set_shield_fac2
19490 !----------------------------------------------------------------------------
19491 ! SOUBROUTINE FOR AFM
19492        subroutine AFMvel(Eafmforce)
19493        use MD_data, only:totTafm
19494       real(kind=8),dimension(3) :: diffafm
19495       real(kind=8) :: afmdist,Eafmforce
19496        integer :: i
19497 !C Only for check grad COMMENT if not used for checkgrad
19498 !C      totT=3.0d0
19499 !C--------------------------------------------------------
19500 !C      print *,"wchodze"
19501       afmdist=0.0d0
19502       Eafmforce=0.0d0
19503       do i=1,3
19504       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19505       afmdist=afmdist+diffafm(i)**2
19506       enddo
19507       afmdist=dsqrt(afmdist)
19508 !      totTafm=3.0
19509       Eafmforce=0.5d0*forceAFMconst &
19510       *(distafminit+totTafm*velAFMconst-afmdist)**2
19511 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19512       do i=1,3
19513       gradafm(i,afmend-1)=-forceAFMconst* &
19514        (distafminit+totTafm*velAFMconst-afmdist) &
19515        *diffafm(i)/afmdist
19516       gradafm(i,afmbeg-1)=forceAFMconst* &
19517       (distafminit+totTafm*velAFMconst-afmdist) &
19518       *diffafm(i)/afmdist
19519       enddo
19520 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19521       return
19522       end subroutine AFMvel
19523 !---------------------------------------------------------
19524        subroutine AFMforce(Eafmforce)
19525
19526       real(kind=8),dimension(3) :: diffafm
19527 !      real(kind=8) ::afmdist
19528       real(kind=8) :: afmdist,Eafmforce
19529       integer :: i
19530       afmdist=0.0d0
19531       Eafmforce=0.0d0
19532       do i=1,3
19533       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19534       afmdist=afmdist+diffafm(i)**2
19535       enddo
19536       afmdist=dsqrt(afmdist)
19537 !      print *,afmdist,distafminit
19538       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19539       do i=1,3
19540       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19541       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19542       enddo
19543 !C      print *,'AFM',Eafmforce
19544       return
19545       end subroutine AFMforce
19546
19547 !-----------------------------------------------------------------------------
19548 #ifdef WHAM
19549       subroutine read_ssHist
19550 !      implicit none
19551 !      Includes
19552 !      include 'DIMENSIONS'
19553 !      include "DIMENSIONS.FREE"
19554 !      include 'COMMON.FREE'
19555 !     Local variables
19556       integer :: i,j
19557       character(len=80) :: controlcard
19558
19559       do i=1,dyn_nssHist
19560         call card_concat(controlcard,.true.)
19561         read(controlcard,*) &
19562              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19563       enddo
19564
19565       return
19566       end subroutine read_ssHist
19567 #endif
19568 !-----------------------------------------------------------------------------
19569       integer function indmat(i,j)
19570 !el
19571 ! get the position of the jth ijth fragment of the chain coordinate system
19572 ! in the fromto array.
19573         integer :: i,j
19574
19575         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19576       return
19577       end function indmat
19578 !-----------------------------------------------------------------------------
19579       real(kind=8) function sigm(x)
19580 !el
19581        real(kind=8) :: x
19582         sigm=0.25d0*x
19583       return
19584       end function sigm
19585 !-----------------------------------------------------------------------------
19586 !-----------------------------------------------------------------------------
19587       subroutine alloc_ener_arrays
19588 !EL Allocation of arrays used by module energy
19589       use MD_data, only: mset
19590 !el local variables
19591       integer :: i,j
19592
19593       if(nres.lt.100) then
19594         maxconts=nres
19595       elseif(nres.lt.200) then
19596         maxconts=0.8*nres      ! Max. number of contacts per residue
19597       else
19598         maxconts=0.6*nres ! (maxconts=maxres/4)
19599       endif
19600       maxcont=12*nres      ! Max. number of SC contacts
19601       maxvar=6*nres      ! Max. number of variables
19602 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19603       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19604 !----------------------
19605 ! arrays in subroutine init_int_table
19606 !el#ifdef MPI
19607 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19608 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19609 !el#endif
19610       allocate(nint_gr(nres))
19611       allocate(nscp_gr(nres))
19612       allocate(ielstart(nres))
19613       allocate(ielend(nres))
19614 !(maxres)
19615       allocate(istart(nres,maxint_gr))
19616       allocate(iend(nres,maxint_gr))
19617 !(maxres,maxint_gr)
19618       allocate(iscpstart(nres,maxint_gr))
19619       allocate(iscpend(nres,maxint_gr))
19620 !(maxres,maxint_gr)
19621       allocate(ielstart_vdw(nres))
19622       allocate(ielend_vdw(nres))
19623 !(maxres)
19624       allocate(nint_gr_nucl(nres))
19625       allocate(nscp_gr_nucl(nres))
19626       allocate(ielstart_nucl(nres))
19627       allocate(ielend_nucl(nres))
19628 !(maxres)
19629       allocate(istart_nucl(nres,maxint_gr))
19630       allocate(iend_nucl(nres,maxint_gr))
19631 !(maxres,maxint_gr)
19632       allocate(iscpstart_nucl(nres,maxint_gr))
19633       allocate(iscpend_nucl(nres,maxint_gr))
19634 !(maxres,maxint_gr)
19635       allocate(ielstart_vdw_nucl(nres))
19636       allocate(ielend_vdw_nucl(nres))
19637
19638       allocate(lentyp(0:nfgtasks-1))
19639 !(0:maxprocs-1)
19640 !----------------------
19641 ! commom.contacts
19642 !      common /contacts/
19643       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19644       allocate(icont(2,maxcont))
19645 !(2,maxcont)
19646 !      common /contacts1/
19647       allocate(num_cont(0:nres+4))
19648 !(maxres)
19649       allocate(jcont(maxconts,nres))
19650 !(maxconts,maxres)
19651       allocate(facont(maxconts,nres))
19652 !(maxconts,maxres)
19653       allocate(gacont(3,maxconts,nres))
19654 !(3,maxconts,maxres)
19655 !      common /contacts_hb/
19656       allocate(gacontp_hb1(3,maxconts,nres))
19657       allocate(gacontp_hb2(3,maxconts,nres))
19658       allocate(gacontp_hb3(3,maxconts,nres))
19659       allocate(gacontm_hb1(3,maxconts,nres))
19660       allocate(gacontm_hb2(3,maxconts,nres))
19661       allocate(gacontm_hb3(3,maxconts,nres))
19662       allocate(gacont_hbr(3,maxconts,nres))
19663       allocate(grij_hb_cont(3,maxconts,nres))
19664 !(3,maxconts,maxres)
19665       allocate(facont_hb(maxconts,nres))
19666
19667       allocate(ees0p(maxconts,nres))
19668       allocate(ees0m(maxconts,nres))
19669       allocate(d_cont(maxconts,nres))
19670       allocate(ees0plist(maxconts,nres))
19671
19672 !(maxconts,maxres)
19673       allocate(num_cont_hb(nres))
19674 !(maxres)
19675       allocate(jcont_hb(maxconts,nres))
19676 !(maxconts,maxres)
19677 !      common /rotat/
19678       allocate(Ug(2,2,nres))
19679       allocate(Ugder(2,2,nres))
19680       allocate(Ug2(2,2,nres))
19681       allocate(Ug2der(2,2,nres))
19682 !(2,2,maxres)
19683       allocate(obrot(2,nres))
19684       allocate(obrot2(2,nres))
19685       allocate(obrot_der(2,nres))
19686       allocate(obrot2_der(2,nres))
19687 !(2,maxres)
19688 !      common /precomp1/
19689       allocate(mu(2,nres))
19690       allocate(muder(2,nres))
19691       allocate(Ub2(2,nres))
19692       Ub2(1,:)=0.0d0
19693       Ub2(2,:)=0.0d0
19694       allocate(Ub2der(2,nres))
19695       allocate(Ctobr(2,nres))
19696       allocate(Ctobrder(2,nres))
19697       allocate(Dtobr2(2,nres))
19698       allocate(Dtobr2der(2,nres))
19699 !(2,maxres)
19700       allocate(EUg(2,2,nres))
19701       allocate(EUgder(2,2,nres))
19702       allocate(CUg(2,2,nres))
19703       allocate(CUgder(2,2,nres))
19704       allocate(DUg(2,2,nres))
19705       allocate(Dugder(2,2,nres))
19706       allocate(DtUg2(2,2,nres))
19707       allocate(DtUg2der(2,2,nres))
19708 !(2,2,maxres)
19709 !      common /precomp2/
19710       allocate(Ug2Db1t(2,nres))
19711       allocate(Ug2Db1tder(2,nres))
19712       allocate(CUgb2(2,nres))
19713       allocate(CUgb2der(2,nres))
19714 !(2,maxres)
19715       allocate(EUgC(2,2,nres))
19716       allocate(EUgCder(2,2,nres))
19717       allocate(EUgD(2,2,nres))
19718       allocate(EUgDder(2,2,nres))
19719       allocate(DtUg2EUg(2,2,nres))
19720       allocate(Ug2DtEUg(2,2,nres))
19721 !(2,2,maxres)
19722       allocate(Ug2DtEUgder(2,2,2,nres))
19723       allocate(DtUg2EUgder(2,2,2,nres))
19724 !(2,2,2,maxres)
19725 !      common /rotat_old/
19726       allocate(costab(nres))
19727       allocate(sintab(nres))
19728       allocate(costab2(nres))
19729       allocate(sintab2(nres))
19730 !(maxres)
19731 !      common /dipmat/
19732       allocate(a_chuj(2,2,maxconts,nres))
19733 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19734       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19735 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19736 !      common /contdistrib/
19737       allocate(ncont_sent(nres))
19738       allocate(ncont_recv(nres))
19739
19740       allocate(iat_sent(nres))
19741 !(maxres)
19742       allocate(iint_sent(4,nres,nres))
19743       allocate(iint_sent_local(4,nres,nres))
19744 !(4,maxres,maxres)
19745       allocate(iturn3_sent(4,0:nres+4))
19746       allocate(iturn4_sent(4,0:nres+4))
19747       allocate(iturn3_sent_local(4,nres))
19748       allocate(iturn4_sent_local(4,nres))
19749 !(4,maxres)
19750       allocate(itask_cont_from(0:nfgtasks-1))
19751       allocate(itask_cont_to(0:nfgtasks-1))
19752 !(0:max_fg_procs-1)
19753
19754
19755
19756 !----------------------
19757 ! commom.deriv;
19758 !      common /derivat/
19759       allocate(dcdv(6,maxdim))
19760       allocate(dxdv(6,maxdim))
19761 !(6,maxdim)
19762       allocate(dxds(6,nres))
19763 !(6,maxres)
19764       allocate(gradx(3,-1:nres,0:2))
19765       allocate(gradc(3,-1:nres,0:2))
19766 !(3,maxres,2)
19767       allocate(gvdwx(3,-1:nres))
19768       allocate(gvdwc(3,-1:nres))
19769       allocate(gelc(3,-1:nres))
19770       allocate(gelc_long(3,-1:nres))
19771       allocate(gvdwpp(3,-1:nres))
19772       allocate(gvdwc_scpp(3,-1:nres))
19773       allocate(gradx_scp(3,-1:nres))
19774       allocate(gvdwc_scp(3,-1:nres))
19775       allocate(ghpbx(3,-1:nres))
19776       allocate(ghpbc(3,-1:nres))
19777       allocate(gradcorr(3,-1:nres))
19778       allocate(gradcorr_long(3,-1:nres))
19779       allocate(gradcorr5_long(3,-1:nres))
19780       allocate(gradcorr6_long(3,-1:nres))
19781       allocate(gcorr6_turn_long(3,-1:nres))
19782       allocate(gradxorr(3,-1:nres))
19783       allocate(gradcorr5(3,-1:nres))
19784       allocate(gradcorr6(3,-1:nres))
19785       allocate(gliptran(3,-1:nres))
19786       allocate(gliptranc(3,-1:nres))
19787       allocate(gliptranx(3,-1:nres))
19788       allocate(gshieldx(3,-1:nres))
19789       allocate(gshieldc(3,-1:nres))
19790       allocate(gshieldc_loc(3,-1:nres))
19791       allocate(gshieldx_ec(3,-1:nres))
19792       allocate(gshieldc_ec(3,-1:nres))
19793       allocate(gshieldc_loc_ec(3,-1:nres))
19794       allocate(gshieldx_t3(3,-1:nres))
19795       allocate(gshieldc_t3(3,-1:nres))
19796       allocate(gshieldc_loc_t3(3,-1:nres))
19797       allocate(gshieldx_t4(3,-1:nres))
19798       allocate(gshieldc_t4(3,-1:nres))
19799       allocate(gshieldc_loc_t4(3,-1:nres))
19800       allocate(gshieldx_ll(3,-1:nres))
19801       allocate(gshieldc_ll(3,-1:nres))
19802       allocate(gshieldc_loc_ll(3,-1:nres))
19803       allocate(grad_shield(3,-1:nres))
19804       allocate(gg_tube_sc(3,-1:nres))
19805       allocate(gg_tube(3,-1:nres))
19806       allocate(gradafm(3,-1:nres))
19807       allocate(gradb_nucl(3,-1:nres))
19808       allocate(gradbx_nucl(3,-1:nres))
19809       allocate(gvdwpsb1(3,-1:nres))
19810       allocate(gelpp(3,-1:nres))
19811       allocate(gvdwpsb(3,-1:nres))
19812       allocate(gelsbc(3,-1:nres))
19813       allocate(gelsbx(3,-1:nres))
19814       allocate(gvdwsbx(3,-1:nres))
19815       allocate(gvdwsbc(3,-1:nres))
19816       allocate(gsbloc(3,-1:nres))
19817       allocate(gsblocx(3,-1:nres))
19818       allocate(gradcorr_nucl(3,-1:nres))
19819       allocate(gradxorr_nucl(3,-1:nres))
19820       allocate(gradcorr3_nucl(3,-1:nres))
19821       allocate(gradxorr3_nucl(3,-1:nres))
19822       allocate(gvdwpp_nucl(3,-1:nres))
19823       allocate(gradpepcat(3,-1:nres))
19824       allocate(gradpepcatx(3,-1:nres))
19825       allocate(gradcatcat(3,-1:nres))
19826 !(3,maxres)
19827       allocate(grad_shield_side(3,50,nres))
19828       allocate(grad_shield_loc(3,50,nres))
19829 ! grad for shielding surroing
19830       allocate(gloc(0:maxvar,0:2))
19831       allocate(gloc_x(0:maxvar,2))
19832 !(maxvar,2)
19833       allocate(gel_loc(3,-1:nres))
19834       allocate(gel_loc_long(3,-1:nres))
19835       allocate(gcorr3_turn(3,-1:nres))
19836       allocate(gcorr4_turn(3,-1:nres))
19837       allocate(gcorr6_turn(3,-1:nres))
19838       allocate(gradb(3,-1:nres))
19839       allocate(gradbx(3,-1:nres))
19840 !(3,maxres)
19841       allocate(gel_loc_loc(maxvar))
19842       allocate(gel_loc_turn3(maxvar))
19843       allocate(gel_loc_turn4(maxvar))
19844       allocate(gel_loc_turn6(maxvar))
19845       allocate(gcorr_loc(maxvar))
19846       allocate(g_corr5_loc(maxvar))
19847       allocate(g_corr6_loc(maxvar))
19848 !(maxvar)
19849       allocate(gsccorc(3,-1:nres))
19850       allocate(gsccorx(3,-1:nres))
19851 !(3,maxres)
19852       allocate(gsccor_loc(-1:nres))
19853 !(maxres)
19854       allocate(gvdwx_scbase(3,-1:nres))
19855       allocate(gvdwc_scbase(3,-1:nres))
19856       allocate(gvdwx_pepbase(3,-1:nres))
19857       allocate(gvdwc_pepbase(3,-1:nres))
19858       allocate(gvdwx_scpho(3,-1:nres))
19859       allocate(gvdwc_scpho(3,-1:nres))
19860       allocate(gvdwc_peppho(3,-1:nres))
19861
19862       allocate(dtheta(3,2,-1:nres))
19863 !(3,2,maxres)
19864       allocate(gscloc(3,-1:nres))
19865       allocate(gsclocx(3,-1:nres))
19866 !(3,maxres)
19867       allocate(dphi(3,3,-1:nres))
19868       allocate(dalpha(3,3,-1:nres))
19869       allocate(domega(3,3,-1:nres))
19870 !(3,3,maxres)
19871 !      common /deriv_scloc/
19872       allocate(dXX_C1tab(3,nres))
19873       allocate(dYY_C1tab(3,nres))
19874       allocate(dZZ_C1tab(3,nres))
19875       allocate(dXX_Ctab(3,nres))
19876       allocate(dYY_Ctab(3,nres))
19877       allocate(dZZ_Ctab(3,nres))
19878       allocate(dXX_XYZtab(3,nres))
19879       allocate(dYY_XYZtab(3,nres))
19880       allocate(dZZ_XYZtab(3,nres))
19881 !(3,maxres)
19882 !      common /mpgrad/
19883       allocate(jgrad_start(nres))
19884       allocate(jgrad_end(nres))
19885 !(maxres)
19886 !----------------------
19887
19888 !      common /indices/
19889       allocate(ibond_displ(0:nfgtasks-1))
19890       allocate(ibond_count(0:nfgtasks-1))
19891       allocate(ithet_displ(0:nfgtasks-1))
19892       allocate(ithet_count(0:nfgtasks-1))
19893       allocate(iphi_displ(0:nfgtasks-1))
19894       allocate(iphi_count(0:nfgtasks-1))
19895       allocate(iphi1_displ(0:nfgtasks-1))
19896       allocate(iphi1_count(0:nfgtasks-1))
19897       allocate(ivec_displ(0:nfgtasks-1))
19898       allocate(ivec_count(0:nfgtasks-1))
19899       allocate(iset_displ(0:nfgtasks-1))
19900       allocate(iset_count(0:nfgtasks-1))
19901       allocate(iint_count(0:nfgtasks-1))
19902       allocate(iint_displ(0:nfgtasks-1))
19903 !(0:max_fg_procs-1)
19904 !----------------------
19905 ! common.MD
19906 !      common /mdgrad/
19907       allocate(gcart(3,-1:nres))
19908       allocate(gxcart(3,-1:nres))
19909 !(3,0:MAXRES)
19910       allocate(gradcag(3,-1:nres))
19911       allocate(gradxag(3,-1:nres))
19912 !(3,MAXRES)
19913 !      common /back_constr/
19914 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19915       allocate(dutheta(nres))
19916       allocate(dugamma(nres))
19917 !(maxres)
19918       allocate(duscdiff(3,nres))
19919       allocate(duscdiffx(3,nres))
19920 !(3,maxres)
19921 !el i io:read_fragments
19922 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19923 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19924 !      common /qmeas/
19925 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19926 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19927       allocate(mset(0:nprocs))  !(maxprocs/20)
19928       mset(:)=0
19929 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19930 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19931       allocate(dUdconst(3,0:nres))
19932       allocate(dUdxconst(3,0:nres))
19933       allocate(dqwol(3,0:nres))
19934       allocate(dxqwol(3,0:nres))
19935 !(3,0:MAXRES)
19936 !----------------------
19937 ! common.sbridge
19938 !      common /sbridge/ in io_common: read_bridge
19939 !el    allocate((:),allocatable :: iss      !(maxss)
19940 !      common /links/  in io_common: read_bridge
19941 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19942 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19943 !      common /dyn_ssbond/
19944 ! and side-chain vectors in theta or phi.
19945       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19946 !(maxres,maxres)
19947 !      do i=1,nres
19948 !        do j=i+1,nres
19949       dyn_ssbond_ij(:,:)=1.0d300
19950 !        enddo
19951 !      enddo
19952
19953 !      if (nss.gt.0) then
19954         allocate(idssb(maxdim),jdssb(maxdim))
19955 !        allocate(newihpb(nss),newjhpb(nss))
19956 !(maxdim)
19957 !      endif
19958       allocate(ishield_list(nres))
19959       allocate(shield_list(50,nres))
19960       allocate(dyn_ss_mask(nres))
19961       allocate(fac_shield(nres))
19962       allocate(enetube(nres*2))
19963       allocate(enecavtube(nres*2))
19964
19965 !(maxres)
19966       dyn_ss_mask(:)=.false.
19967 !----------------------
19968 ! common.sccor
19969 ! Parameters of the SCCOR term
19970 !      common/sccor/
19971 !el in io_conf: parmread
19972 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
19973 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
19974 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
19975 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
19976 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
19977 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
19978 !      allocate(vlor1sccor(maxterm_sccor,20,20))
19979 !      allocate(vlor2sccor(maxterm_sccor,20,20))
19980 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
19981 !----------------
19982       allocate(gloc_sc(3,0:2*nres,0:10))
19983 !(3,0:maxres2,10)maxres2=2*maxres
19984       allocate(dcostau(3,3,3,2*nres))
19985       allocate(dsintau(3,3,3,2*nres))
19986       allocate(dtauangle(3,3,3,2*nres))
19987       allocate(dcosomicron(3,3,3,2*nres))
19988       allocate(domicron(3,3,3,2*nres))
19989 !(3,3,3,maxres2)maxres2=2*maxres
19990 !----------------------
19991 ! common.var
19992 !      common /restr/
19993       allocate(varall(maxvar))
19994 !(maxvar)(maxvar=6*maxres)
19995       allocate(mask_theta(nres))
19996       allocate(mask_phi(nres))
19997       allocate(mask_side(nres))
19998 !(maxres)
19999 !----------------------
20000 ! common.vectors
20001 !      common /vectors/
20002       allocate(uy(3,nres))
20003       allocate(uz(3,nres))
20004 !(3,maxres)
20005       allocate(uygrad(3,3,2,nres))
20006       allocate(uzgrad(3,3,2,nres))
20007 !(3,3,2,maxres)
20008
20009       return
20010       end subroutine alloc_ener_arrays
20011 !-----------------------------------------------------------------
20012       subroutine ebond_nucl(estr_nucl)
20013 !c
20014 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20015 !c
20016
20017       real(kind=8),dimension(3) :: u,ud
20018       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20019       real(kind=8) :: estr_nucl,diff
20020       integer :: iti,i,j,k,nbi
20021       estr_nucl=0.0d0
20022 !C      print *,"I enter ebond"
20023       if (energy_dec) &
20024       write (iout,*) "ibondp_start,ibondp_end",&
20025        ibondp_nucl_start,ibondp_nucl_end
20026       do i=ibondp_nucl_start,ibondp_nucl_end
20027         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20028          itype(i,2).eq.ntyp1_molec(2)) cycle
20029 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20030 !          do j=1,3
20031 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20032 !     &      *dc(j,i-1)/vbld(i)
20033 !          enddo
20034 !          if (energy_dec) write(iout,*)
20035 !     &       "estr1",i,vbld(i),distchainmax,
20036 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20037
20038           diff = vbld(i)-vbldp0_nucl
20039           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20040           vbldp0_nucl,diff,AKP_nucl*diff*diff
20041           estr_nucl=estr_nucl+diff*diff
20042 !          print *,estr_nucl
20043           do j=1,3
20044             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20045           enddo
20046 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20047       enddo
20048       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20049 !      print *,"partial sum", estr_nucl,AKP_nucl
20050
20051       if (energy_dec) &
20052       write (iout,*) "ibondp_start,ibondp_end",&
20053        ibond_nucl_start,ibond_nucl_end
20054
20055       do i=ibond_nucl_start,ibond_nucl_end
20056 !C        print *, "I am stuck",i
20057         iti=itype(i,2)
20058         if (iti.eq.ntyp1_molec(2)) cycle
20059           nbi=nbondterm_nucl(iti)
20060 !C        print *,iti,nbi
20061           if (nbi.eq.1) then
20062             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20063
20064             if (energy_dec) &
20065            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20066            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20067             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20068 !            print *,estr_nucl
20069             do j=1,3
20070               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20071             enddo
20072           else
20073             do j=1,nbi
20074               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20075               ud(j)=aksc_nucl(j,iti)*diff
20076               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20077             enddo
20078             uprod=u(1)
20079             do j=2,nbi
20080               uprod=uprod*u(j)
20081             enddo
20082             usum=0.0d0
20083             usumsqder=0.0d0
20084             do j=1,nbi
20085               uprod1=1.0d0
20086               uprod2=1.0d0
20087               do k=1,nbi
20088                 if (k.ne.j) then
20089                   uprod1=uprod1*u(k)
20090                   uprod2=uprod2*u(k)*u(k)
20091                 endif
20092               enddo
20093               usum=usum+uprod1
20094               usumsqder=usumsqder+ud(j)*uprod2
20095             enddo
20096             estr_nucl=estr_nucl+uprod/usum
20097             do j=1,3
20098              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20099             enddo
20100         endif
20101       enddo
20102 !C      print *,"I am about to leave ebond"
20103       return
20104       end subroutine ebond_nucl
20105
20106 !-----------------------------------------------------------------------------
20107       subroutine ebend_nucl(etheta_nucl)
20108       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20109       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20110       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20111       logical :: lprn=.false., lprn1=.false.
20112 !el local variables
20113       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20114       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20115       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20116 ! local variables for constrains
20117       real(kind=8) :: difi,thetiii
20118        integer itheta
20119       etheta_nucl=0.0D0
20120 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20121       do i=ithet_nucl_start,ithet_nucl_end
20122         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20123         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20124         (itype(i,2).eq.ntyp1_molec(2))) cycle
20125         dethetai=0.0d0
20126         dephii=0.0d0
20127         dephii1=0.0d0
20128         theti2=0.5d0*theta(i)
20129         ityp2=ithetyp_nucl(itype(i-1,2))
20130         do k=1,nntheterm_nucl
20131           coskt(k)=dcos(k*theti2)
20132           sinkt(k)=dsin(k*theti2)
20133         enddo
20134         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20135 #ifdef OSF
20136           phii=phi(i)
20137           if (phii.ne.phii) phii=150.0
20138 #else
20139           phii=phi(i)
20140 #endif
20141           ityp1=ithetyp_nucl(itype(i-2,2))
20142           do k=1,nsingle_nucl
20143             cosph1(k)=dcos(k*phii)
20144             sinph1(k)=dsin(k*phii)
20145           enddo
20146         else
20147           phii=0.0d0
20148           ityp1=nthetyp_nucl+1
20149           do k=1,nsingle_nucl
20150             cosph1(k)=0.0d0
20151             sinph1(k)=0.0d0
20152           enddo
20153         endif
20154
20155         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20156 #ifdef OSF
20157           phii1=phi(i+1)
20158           if (phii1.ne.phii1) phii1=150.0
20159           phii1=pinorm(phii1)
20160 #else
20161           phii1=phi(i+1)
20162 #endif
20163           ityp3=ithetyp_nucl(itype(i,2))
20164           do k=1,nsingle_nucl
20165             cosph2(k)=dcos(k*phii1)
20166             sinph2(k)=dsin(k*phii1)
20167           enddo
20168         else
20169           phii1=0.0d0
20170           ityp3=nthetyp_nucl+1
20171           do k=1,nsingle_nucl
20172             cosph2(k)=0.0d0
20173             sinph2(k)=0.0d0
20174           enddo
20175         endif
20176         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20177         do k=1,ndouble_nucl
20178           do l=1,k-1
20179             ccl=cosph1(l)*cosph2(k-l)
20180             ssl=sinph1(l)*sinph2(k-l)
20181             scl=sinph1(l)*cosph2(k-l)
20182             csl=cosph1(l)*sinph2(k-l)
20183             cosph1ph2(l,k)=ccl-ssl
20184             cosph1ph2(k,l)=ccl+ssl
20185             sinph1ph2(l,k)=scl+csl
20186             sinph1ph2(k,l)=scl-csl
20187           enddo
20188         enddo
20189         if (lprn) then
20190         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20191          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20192         write (iout,*) "coskt and sinkt",nntheterm_nucl
20193         do k=1,nntheterm_nucl
20194           write (iout,*) k,coskt(k),sinkt(k)
20195         enddo
20196         endif
20197         do k=1,ntheterm_nucl
20198           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20199           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20200            *coskt(k)
20201           if (lprn)&
20202          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20203           " ethetai",ethetai
20204         enddo
20205         if (lprn) then
20206         write (iout,*) "cosph and sinph"
20207         do k=1,nsingle_nucl
20208           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20209         enddo
20210         write (iout,*) "cosph1ph2 and sinph2ph2"
20211         do k=2,ndouble_nucl
20212           do l=1,k-1
20213             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20214               sinph1ph2(l,k),sinph1ph2(k,l)
20215           enddo
20216         enddo
20217         write(iout,*) "ethetai",ethetai
20218         endif
20219         do m=1,ntheterm2_nucl
20220           do k=1,nsingle_nucl
20221             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20222               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20223               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20224               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20225             ethetai=ethetai+sinkt(m)*aux
20226             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20227             dephii=dephii+k*sinkt(m)*(&
20228                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20229                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20230             dephii1=dephii1+k*sinkt(m)*(&
20231                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20232                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20233             if (lprn) &
20234            write (iout,*) "m",m," k",k," bbthet",&
20235               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20236               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20237               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20238               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20239           enddo
20240         enddo
20241         if (lprn) &
20242         write(iout,*) "ethetai",ethetai
20243         do m=1,ntheterm3_nucl
20244           do k=2,ndouble_nucl
20245             do l=1,k-1
20246               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20247                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20248                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20249                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20250               ethetai=ethetai+sinkt(m)*aux
20251               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20252               dephii=dephii+l*sinkt(m)*(&
20253                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20254                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20255                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20256                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20257               dephii1=dephii1+(k-l)*sinkt(m)*( &
20258                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20259                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20260                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20261                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20262               if (lprn) then
20263               write (iout,*) "m",m," k",k," l",l," ffthet", &
20264                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20265                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20266                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20267                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20268               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20269                  cosph1ph2(k,l)*sinkt(m),&
20270                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20271               endif
20272             enddo
20273           enddo
20274         enddo
20275 10      continue
20276         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20277         i,theta(i)*rad2deg,phii*rad2deg, &
20278         phii1*rad2deg,ethetai
20279         etheta_nucl=etheta_nucl+ethetai
20280 !        print *,i,"partial sum",etheta_nucl
20281         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20282         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20283         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20284       enddo
20285       return
20286       end subroutine ebend_nucl
20287 !----------------------------------------------------
20288       subroutine etor_nucl(etors_nucl)
20289 !      implicit real*8 (a-h,o-z)
20290 !      include 'DIMENSIONS'
20291 !      include 'COMMON.VAR'
20292 !      include 'COMMON.GEO'
20293 !      include 'COMMON.LOCAL'
20294 !      include 'COMMON.TORSION'
20295 !      include 'COMMON.INTERACT'
20296 !      include 'COMMON.DERIV'
20297 !      include 'COMMON.CHAIN'
20298 !      include 'COMMON.NAMES'
20299 !      include 'COMMON.IOUNITS'
20300 !      include 'COMMON.FFIELD'
20301 !      include 'COMMON.TORCNSTR'
20302 !      include 'COMMON.CONTROL'
20303       real(kind=8) :: etors_nucl,edihcnstr
20304       logical :: lprn
20305 !el local variables
20306       integer :: i,j,iblock,itori,itori1
20307       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20308                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20309 ! Set lprn=.true. for debugging
20310       lprn=.false.
20311 !     lprn=.true.
20312       etors_nucl=0.0D0
20313 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20314       do i=iphi_nucl_start,iphi_nucl_end
20315         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20316              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20317              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20318         etors_ii=0.0D0
20319         itori=itortyp_nucl(itype(i-2,2))
20320         itori1=itortyp_nucl(itype(i-1,2))
20321         phii=phi(i)
20322 !         print *,i,itori,itori1
20323         gloci=0.0D0
20324 !C Regular cosine and sine terms
20325         do j=1,nterm_nucl(itori,itori1)
20326           v1ij=v1_nucl(j,itori,itori1)
20327           v2ij=v2_nucl(j,itori,itori1)
20328           cosphi=dcos(j*phii)
20329           sinphi=dsin(j*phii)
20330           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20331           if (energy_dec) etors_ii=etors_ii+&
20332                      v1ij*cosphi+v2ij*sinphi
20333           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20334         enddo
20335 !C Lorentz terms
20336 !C                         v1
20337 !C  E = SUM ----------------------------------- - v1
20338 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20339 !C
20340         cosphi=dcos(0.5d0*phii)
20341         sinphi=dsin(0.5d0*phii)
20342         do j=1,nlor_nucl(itori,itori1)
20343           vl1ij=vlor1_nucl(j,itori,itori1)
20344           vl2ij=vlor2_nucl(j,itori,itori1)
20345           vl3ij=vlor3_nucl(j,itori,itori1)
20346           pom=vl2ij*cosphi+vl3ij*sinphi
20347           pom1=1.0d0/(pom*pom+1.0d0)
20348           etors_nucl=etors_nucl+vl1ij*pom1
20349           if (energy_dec) etors_ii=etors_ii+ &
20350                      vl1ij*pom1
20351           pom=-pom*pom1*pom1
20352           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20353         enddo
20354 !C Subtract the constant term
20355         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20356           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20357               'etor',i,etors_ii-v0_nucl(itori,itori1)
20358         if (lprn) &
20359        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20360        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20361        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20362         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20363 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20364       enddo
20365       return
20366       end subroutine etor_nucl
20367 !------------------------------------------------------------
20368       subroutine epp_nucl_sub(evdw1,ees)
20369 !C
20370 !C This subroutine calculates the average interaction energy and its gradient
20371 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20372 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20373 !C The potential depends both on the distance of peptide-group centers and on
20374 !C the orientation of the CA-CA virtual bonds.
20375 !C
20376       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20377       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20378       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20379                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20380                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20381       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20382                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20383       integer xshift,yshift,zshift
20384       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20385       real(kind=8) :: ees,eesij
20386 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20387       real(kind=8) scal_el /0.5d0/
20388       t_eelecij=0.0d0
20389       ees=0.0D0
20390       evdw1=0.0D0
20391       ind=0
20392 !c
20393 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20394 !c
20395 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20396       do i=iatel_s_nucl,iatel_e_nucl
20397         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20398         dxi=dc(1,i)
20399         dyi=dc(2,i)
20400         dzi=dc(3,i)
20401         dx_normi=dc_norm(1,i)
20402         dy_normi=dc_norm(2,i)
20403         dz_normi=dc_norm(3,i)
20404         xmedi=c(1,i)+0.5d0*dxi
20405         ymedi=c(2,i)+0.5d0*dyi
20406         zmedi=c(3,i)+0.5d0*dzi
20407           xmedi=dmod(xmedi,boxxsize)
20408           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20409           ymedi=dmod(ymedi,boxysize)
20410           if (ymedi.lt.0) ymedi=ymedi+boxysize
20411           zmedi=dmod(zmedi,boxzsize)
20412           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20413
20414         do j=ielstart_nucl(i),ielend_nucl(i)
20415           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20416           ind=ind+1
20417           dxj=dc(1,j)
20418           dyj=dc(2,j)
20419           dzj=dc(3,j)
20420 !          xj=c(1,j)+0.5D0*dxj-xmedi
20421 !          yj=c(2,j)+0.5D0*dyj-ymedi
20422 !          zj=c(3,j)+0.5D0*dzj-zmedi
20423           xj=c(1,j)+0.5D0*dxj
20424           yj=c(2,j)+0.5D0*dyj
20425           zj=c(3,j)+0.5D0*dzj
20426           xj=mod(xj,boxxsize)
20427           if (xj.lt.0) xj=xj+boxxsize
20428           yj=mod(yj,boxysize)
20429           if (yj.lt.0) yj=yj+boxysize
20430           zj=mod(zj,boxzsize)
20431           if (zj.lt.0) zj=zj+boxzsize
20432       isubchap=0
20433       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20434       xj_safe=xj
20435       yj_safe=yj
20436       zj_safe=zj
20437       do xshift=-1,1
20438       do yshift=-1,1
20439       do zshift=-1,1
20440           xj=xj_safe+xshift*boxxsize
20441           yj=yj_safe+yshift*boxysize
20442           zj=zj_safe+zshift*boxzsize
20443           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20444           if(dist_temp.lt.dist_init) then
20445             dist_init=dist_temp
20446             xj_temp=xj
20447             yj_temp=yj
20448             zj_temp=zj
20449             isubchap=1
20450           endif
20451        enddo
20452        enddo
20453        enddo
20454        if (isubchap.eq.1) then
20455 !C          print *,i,j
20456           xj=xj_temp-xmedi
20457           yj=yj_temp-ymedi
20458           zj=zj_temp-zmedi
20459        else
20460           xj=xj_safe-xmedi
20461           yj=yj_safe-ymedi
20462           zj=zj_safe-zmedi
20463        endif
20464
20465           rij=xj*xj+yj*yj+zj*zj
20466 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20467           fac=(r0pp**2/rij)**3
20468           ev1=epspp*fac*fac
20469           ev2=epspp*fac
20470           evdw1ij=ev1-2*ev2
20471           fac=(-ev1-evdw1ij)/rij
20472 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20473           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20474           evdw1=evdw1+evdw1ij
20475 !C
20476 !C Calculate contributions to the Cartesian gradient.
20477 !C
20478           ggg(1)=fac*xj
20479           ggg(2)=fac*yj
20480           ggg(3)=fac*zj
20481           do k=1,3
20482             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20483             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20484           enddo
20485 !c phoshate-phosphate electrostatic interactions
20486           rij=dsqrt(rij)
20487           fac=1.0d0/rij
20488           eesij=dexp(-BEES*rij)*fac
20489 !          write (2,*)"fac",fac," eesijpp",eesij
20490           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20491           ees=ees+eesij
20492 !c          fac=-eesij*fac
20493           fac=-(fac+BEES)*eesij*fac
20494           ggg(1)=fac*xj
20495           ggg(2)=fac*yj
20496           ggg(3)=fac*zj
20497 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20498 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20499 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20500           do k=1,3
20501             gelpp(k,i)=gelpp(k,i)-ggg(k)
20502             gelpp(k,j)=gelpp(k,j)+ggg(k)
20503           enddo
20504         enddo ! j
20505       enddo   ! i
20506 !c      ees=332.0d0*ees
20507       ees=AEES*ees
20508       do i=nnt,nct
20509 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20510         do k=1,3
20511           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20512 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20513           gelpp(k,i)=AEES*gelpp(k,i)
20514         enddo
20515 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20516       enddo
20517 !c      write (2,*) "total EES",ees
20518       return
20519       end subroutine epp_nucl_sub
20520 !---------------------------------------------------------------------
20521       subroutine epsb(evdwpsb,eelpsb)
20522 !      use comm_locel
20523 !C
20524 !C This subroutine calculates the excluded-volume interaction energy between
20525 !C peptide-group centers and side chains and its gradient in virtual-bond and
20526 !C side-chain vectors.
20527 !C
20528       real(kind=8),dimension(3):: ggg
20529       integer :: i,iint,j,k,iteli,itypj,subchap
20530       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20531                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20532       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20533                     dist_temp, dist_init
20534       integer xshift,yshift,zshift
20535
20536 !cd    print '(a)','Enter ESCP'
20537 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20538       eelpsb=0.0d0
20539       evdwpsb=0.0d0
20540 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20541       do i=iatscp_s_nucl,iatscp_e_nucl
20542         if (itype(i,2).eq.ntyp1_molec(2) &
20543          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20544         xi=0.5D0*(c(1,i)+c(1,i+1))
20545         yi=0.5D0*(c(2,i)+c(2,i+1))
20546         zi=0.5D0*(c(3,i)+c(3,i+1))
20547           xi=mod(xi,boxxsize)
20548           if (xi.lt.0) xi=xi+boxxsize
20549           yi=mod(yi,boxysize)
20550           if (yi.lt.0) yi=yi+boxysize
20551           zi=mod(zi,boxzsize)
20552           if (zi.lt.0) zi=zi+boxzsize
20553
20554         do iint=1,nscp_gr_nucl(i)
20555
20556         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20557           itypj=itype(j,2)
20558           if (itypj.eq.ntyp1_molec(2)) cycle
20559 !C Uncomment following three lines for SC-p interactions
20560 !c         xj=c(1,nres+j)-xi
20561 !c         yj=c(2,nres+j)-yi
20562 !c         zj=c(3,nres+j)-zi
20563 !C Uncomment following three lines for Ca-p interactions
20564 !          xj=c(1,j)-xi
20565 !          yj=c(2,j)-yi
20566 !          zj=c(3,j)-zi
20567           xj=c(1,j)
20568           yj=c(2,j)
20569           zj=c(3,j)
20570           xj=mod(xj,boxxsize)
20571           if (xj.lt.0) xj=xj+boxxsize
20572           yj=mod(yj,boxysize)
20573           if (yj.lt.0) yj=yj+boxysize
20574           zj=mod(zj,boxzsize)
20575           if (zj.lt.0) zj=zj+boxzsize
20576       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20577       xj_safe=xj
20578       yj_safe=yj
20579       zj_safe=zj
20580       subchap=0
20581       do xshift=-1,1
20582       do yshift=-1,1
20583       do zshift=-1,1
20584           xj=xj_safe+xshift*boxxsize
20585           yj=yj_safe+yshift*boxysize
20586           zj=zj_safe+zshift*boxzsize
20587           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20588           if(dist_temp.lt.dist_init) then
20589             dist_init=dist_temp
20590             xj_temp=xj
20591             yj_temp=yj
20592             zj_temp=zj
20593             subchap=1
20594           endif
20595        enddo
20596        enddo
20597        enddo
20598        if (subchap.eq.1) then
20599           xj=xj_temp-xi
20600           yj=yj_temp-yi
20601           zj=zj_temp-zi
20602        else
20603           xj=xj_safe-xi
20604           yj=yj_safe-yi
20605           zj=zj_safe-zi
20606        endif
20607
20608           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20609           fac=rrij**expon2
20610           e1=fac*fac*aad_nucl(itypj)
20611           e2=fac*bad_nucl(itypj)
20612           if (iabs(j-i) .le. 2) then
20613             e1=scal14*e1
20614             e2=scal14*e2
20615           endif
20616           evdwij=e1+e2
20617           evdwpsb=evdwpsb+evdwij
20618           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20619              'evdw2',i,j,evdwij,"tu4"
20620 !C
20621 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20622 !C
20623           fac=-(evdwij+e1)*rrij
20624           ggg(1)=xj*fac
20625           ggg(2)=yj*fac
20626           ggg(3)=zj*fac
20627           do k=1,3
20628             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20629             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20630           enddo
20631         enddo
20632
20633         enddo ! iint
20634       enddo ! i
20635       do i=1,nct
20636         do j=1,3
20637           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20638           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20639         enddo
20640       enddo
20641       return
20642       end subroutine epsb
20643
20644 !------------------------------------------------------
20645       subroutine esb_gb(evdwsb,eelsb)
20646       use comm_locel
20647       use calc_data_nucl
20648       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20649       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20650       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20651       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20652                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20653       integer :: ii
20654       logical lprn
20655       evdw=0.0D0
20656       eelsb=0.0d0
20657       ecorr=0.0d0
20658       evdwsb=0.0D0
20659       lprn=.false.
20660       ind=0
20661 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20662       do i=iatsc_s_nucl,iatsc_e_nucl
20663         num_conti=0
20664         num_conti2=0
20665         itypi=itype(i,2)
20666 !        PRINT *,"I=",i,itypi
20667         if (itypi.eq.ntyp1_molec(2)) cycle
20668         itypi1=itype(i+1,2)
20669         xi=c(1,nres+i)
20670         yi=c(2,nres+i)
20671         zi=c(3,nres+i)
20672           xi=dmod(xi,boxxsize)
20673           if (xi.lt.0) xi=xi+boxxsize
20674           yi=dmod(yi,boxysize)
20675           if (yi.lt.0) yi=yi+boxysize
20676           zi=dmod(zi,boxzsize)
20677           if (zi.lt.0) zi=zi+boxzsize
20678
20679         dxi=dc_norm(1,nres+i)
20680         dyi=dc_norm(2,nres+i)
20681         dzi=dc_norm(3,nres+i)
20682         dsci_inv=vbld_inv(i+nres)
20683 !C
20684 !C Calculate SC interaction energy.
20685 !C
20686         do iint=1,nint_gr_nucl(i)
20687 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20688           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20689             ind=ind+1
20690 !            print *,"JESTEM"
20691             itypj=itype(j,2)
20692             if (itypj.eq.ntyp1_molec(2)) cycle
20693             dscj_inv=vbld_inv(j+nres)
20694             sig0ij=sigma_nucl(itypi,itypj)
20695             chi1=chi_nucl(itypi,itypj)
20696             chi2=chi_nucl(itypj,itypi)
20697             chi12=chi1*chi2
20698             chip1=chip_nucl(itypi,itypj)
20699             chip2=chip_nucl(itypj,itypi)
20700             chip12=chip1*chip2
20701 !            xj=c(1,nres+j)-xi
20702 !            yj=c(2,nres+j)-yi
20703 !            zj=c(3,nres+j)-zi
20704            xj=c(1,nres+j)
20705            yj=c(2,nres+j)
20706            zj=c(3,nres+j)
20707           xj=dmod(xj,boxxsize)
20708           if (xj.lt.0) xj=xj+boxxsize
20709           yj=dmod(yj,boxysize)
20710           if (yj.lt.0) yj=yj+boxysize
20711           zj=dmod(zj,boxzsize)
20712           if (zj.lt.0) zj=zj+boxzsize
20713       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20714       xj_safe=xj
20715       yj_safe=yj
20716       zj_safe=zj
20717       subchap=0
20718       do xshift=-1,1
20719       do yshift=-1,1
20720       do zshift=-1,1
20721           xj=xj_safe+xshift*boxxsize
20722           yj=yj_safe+yshift*boxysize
20723           zj=zj_safe+zshift*boxzsize
20724           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20725           if(dist_temp.lt.dist_init) then
20726             dist_init=dist_temp
20727             xj_temp=xj
20728             yj_temp=yj
20729             zj_temp=zj
20730             subchap=1
20731           endif
20732        enddo
20733        enddo
20734        enddo
20735        if (subchap.eq.1) then
20736           xj=xj_temp-xi
20737           yj=yj_temp-yi
20738           zj=zj_temp-zi
20739        else
20740           xj=xj_safe-xi
20741           yj=yj_safe-yi
20742           zj=zj_safe-zi
20743        endif
20744
20745             dxj=dc_norm(1,nres+j)
20746             dyj=dc_norm(2,nres+j)
20747             dzj=dc_norm(3,nres+j)
20748             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20749             rij=dsqrt(rrij)
20750 !C Calculate angle-dependent terms of energy and contributions to their
20751 !C derivatives.
20752             erij(1)=xj*rij
20753             erij(2)=yj*rij
20754             erij(3)=zj*rij
20755             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20756             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20757             om12=dxi*dxj+dyi*dyj+dzi*dzj
20758             call sc_angular_nucl
20759             sigsq=1.0D0/sigsq
20760             sig=sig0ij*dsqrt(sigsq)
20761             rij_shift=1.0D0/rij-sig+sig0ij
20762 !            print *,rij_shift,"rij_shift"
20763 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20764 !c     &       " rij_shift",rij_shift
20765             if (rij_shift.le.0.0D0) then
20766               evdw=1.0D20
20767               return
20768             endif
20769             sigder=-sig*sigsq
20770 !c---------------------------------------------------------------
20771             rij_shift=1.0D0/rij_shift
20772             fac=rij_shift**expon
20773             e1=fac*fac*aa_nucl(itypi,itypj)
20774             e2=fac*bb_nucl(itypi,itypj)
20775             evdwij=eps1*eps2rt*(e1+e2)
20776 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20777 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20778             eps2der=evdwij
20779             evdwij=evdwij*eps2rt
20780             evdwsb=evdwsb+evdwij
20781             if (lprn) then
20782             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
20783             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
20784             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20785              restyp(itypi,2),i,restyp(itypj,2),j, &
20786              epsi,sigm,chi1,chi2,chip1,chip2, &
20787              eps1,eps2rt**2,sig,sig0ij, &
20788              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20789             evdwij
20790             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20791             endif
20792
20793             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20794                              'evdw',i,j,evdwij,"tu3"
20795
20796
20797 !C Calculate gradient components.
20798             e1=e1*eps1*eps2rt**2
20799             fac=-expon*(e1+evdwij)*rij_shift
20800             sigder=fac*sigder
20801             fac=rij*fac
20802 !c            fac=0.0d0
20803 !C Calculate the radial part of the gradient
20804             gg(1)=xj*fac
20805             gg(2)=yj*fac
20806             gg(3)=zj*fac
20807 !C Calculate angular part of the gradient.
20808             call sc_grad_nucl
20809             call eelsbij(eelij,num_conti2)
20810             if (energy_dec .and. &
20811            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20812           write (istat,'(e14.5)') evdwij
20813             eelsb=eelsb+eelij
20814           enddo      ! j
20815         enddo        ! iint
20816         num_cont_hb(i)=num_conti2
20817       enddo          ! i
20818 !c      write (iout,*) "Number of loop steps in EGB:",ind
20819 !cccc      energy_dec=.false.
20820       return
20821       end subroutine esb_gb
20822 !-------------------------------------------------------------------------------
20823       subroutine eelsbij(eesij,num_conti2)
20824       use comm_locel
20825       use calc_data_nucl
20826       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20827       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20828       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20829                     dist_temp, dist_init,rlocshield,fracinbuf
20830       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20831
20832 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20833       real(kind=8) scal_el /0.5d0/
20834       integer :: iteli,itelj,kkk,kkll,m,isubchap
20835       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20836       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20837       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20838                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20839                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20840                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20841                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20842                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20843                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20844                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20845       ind=ind+1
20846       itypi=itype(i,2)
20847       itypj=itype(j,2)
20848 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20849       ael6i=ael6_nucl(itypi,itypj)
20850       ael3i=ael3_nucl(itypi,itypj)
20851       ael63i=ael63_nucl(itypi,itypj)
20852       ael32i=ael32_nucl(itypi,itypj)
20853 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20854 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20855       dxj=dc(1,j+nres)
20856       dyj=dc(2,j+nres)
20857       dzj=dc(3,j+nres)
20858       dx_normi=dc_norm(1,i+nres)
20859       dy_normi=dc_norm(2,i+nres)
20860       dz_normi=dc_norm(3,i+nres)
20861       dx_normj=dc_norm(1,j+nres)
20862       dy_normj=dc_norm(2,j+nres)
20863       dz_normj=dc_norm(3,j+nres)
20864 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20865 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20866 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20867       if (ipot_nucl.ne.2) then
20868         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20869         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20870         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20871       else
20872         cosa=om12
20873         cosb=om1
20874         cosg=om2
20875       endif
20876       r3ij=rij*rrij
20877       r6ij=r3ij*r3ij
20878       fac=cosa-3.0D0*cosb*cosg
20879       facfac=fac*fac
20880       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20881       fac3=ael6i*r6ij
20882       fac4=ael3i*r3ij
20883       fac5=ael63i*r6ij
20884       fac6=ael32i*r6ij
20885 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20886 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20887       el1=fac3*(4.0D0+facfac-fac1)
20888       el2=fac4*fac
20889       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20890       el4=fac6*facfac
20891       eesij=el1+el2+el3+el4
20892 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20893       ees0ij=4.0D0+facfac-fac1
20894
20895       if (energy_dec) then
20896           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20897           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20898            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20899            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20900            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20901           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20902       endif
20903
20904 !C
20905 !C Calculate contributions to the Cartesian gradient.
20906 !C
20907       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20908       fac1=fac
20909 !c      erij(1)=xj*rmij
20910 !c      erij(2)=yj*rmij
20911 !c      erij(3)=zj*rmij
20912 !*
20913 !* Radial derivatives. First process both termini of the fragment (i,j)
20914 !*
20915       ggg(1)=facel*xj
20916       ggg(2)=facel*yj
20917       ggg(3)=facel*zj
20918       do k=1,3
20919         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20920         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20921         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20922         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20923       enddo
20924 !*
20925 !* Angular part
20926 !*
20927       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20928       fac4=-3.0D0*fac4
20929       fac3=-6.0D0*fac3
20930       fac5= 6.0d0*fac5
20931       fac6=-6.0d0*fac6
20932       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20933        fac6*fac1*cosg
20934       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20935        fac6*fac1*cosb
20936       do k=1,3
20937         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20938         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20939       enddo
20940       do k=1,3
20941         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20942       enddo
20943       do k=1,3
20944         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20945              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20946              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
20947         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
20948              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
20949              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
20950         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20951         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20952       enddo
20953 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
20954        IF ( j.gt.i+1 .and.&
20955           num_conti.le.maxconts) THEN
20956 !C
20957 !C Calculate the contact function. The ith column of the array JCONT will
20958 !C contain the numbers of atoms that make contacts with the atom I (of numbers
20959 !C greater than I). The arrays FACONT and GACONT will contain the values of
20960 !C the contact function and its derivative.
20961         r0ij=2.20D0*sigma(itypi,itypj)
20962 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
20963         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
20964 !c        write (2,*) "fcont",fcont
20965         if (fcont.gt.0.0D0) then
20966           num_conti=num_conti+1
20967           num_conti2=num_conti2+1
20968
20969           if (num_conti.gt.maxconts) then
20970             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
20971                           ' will skip next contacts for this conf.'
20972           else
20973             jcont_hb(num_conti,i)=j
20974 !c            write (iout,*) "num_conti",num_conti,
20975 !c     &        " jcont_hb",jcont_hb(num_conti,i)
20976 !C Calculate contact energies
20977             cosa4=4.0D0*cosa
20978             wij=cosa-3.0D0*cosb*cosg
20979             cosbg1=cosb+cosg
20980             cosbg2=cosb-cosg
20981             fac3=dsqrt(-ael6i)*r3ij
20982 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
20983             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
20984             if (ees0tmp.gt.0) then
20985               ees0pij=dsqrt(ees0tmp)
20986             else
20987               ees0pij=0
20988             endif
20989             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
20990             if (ees0tmp.gt.0) then
20991               ees0mij=dsqrt(ees0tmp)
20992             else
20993               ees0mij=0
20994             endif
20995             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
20996             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
20997 !c            write (iout,*) "i",i," j",j,
20998 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
20999             ees0pij1=fac3/ees0pij
21000             ees0mij1=fac3/ees0mij
21001             fac3p=-3.0D0*fac3*rrij
21002             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21003             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21004             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21005             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21006             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21007             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21008             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21009             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21010             ecosap=ecosa1+ecosa2
21011             ecosbp=ecosb1+ecosb2
21012             ecosgp=ecosg1+ecosg2
21013             ecosam=ecosa1-ecosa2
21014             ecosbm=ecosb1-ecosb2
21015             ecosgm=ecosg1-ecosg2
21016 !C End diagnostics
21017             facont_hb(num_conti,i)=fcont
21018             fprimcont=fprimcont/rij
21019             do k=1,3
21020               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21021               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21022             enddo
21023             gggp(1)=gggp(1)+ees0pijp*xj
21024             gggp(2)=gggp(2)+ees0pijp*yj
21025             gggp(3)=gggp(3)+ees0pijp*zj
21026             gggm(1)=gggm(1)+ees0mijp*xj
21027             gggm(2)=gggm(2)+ees0mijp*yj
21028             gggm(3)=gggm(3)+ees0mijp*zj
21029 !C Derivatives due to the contact function
21030             gacont_hbr(1,num_conti,i)=fprimcont*xj
21031             gacont_hbr(2,num_conti,i)=fprimcont*yj
21032             gacont_hbr(3,num_conti,i)=fprimcont*zj
21033             do k=1,3
21034 !c
21035 !c Gradient of the correlation terms
21036 !c
21037               gacontp_hb1(k,num_conti,i)= &
21038              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21039             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21040               gacontp_hb2(k,num_conti,i)= &
21041              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21042             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21043               gacontp_hb3(k,num_conti,i)=gggp(k)
21044               gacontm_hb1(k,num_conti,i)= &
21045              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21046             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21047               gacontm_hb2(k,num_conti,i)= &
21048              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21049             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21050               gacontm_hb3(k,num_conti,i)=gggm(k)
21051             enddo
21052           endif
21053         endif
21054       ENDIF
21055       return
21056       end subroutine eelsbij
21057 !------------------------------------------------------------------
21058       subroutine sc_grad_nucl
21059       use comm_locel
21060       use calc_data_nucl
21061       real(kind=8),dimension(3) :: dcosom1,dcosom2
21062       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21063       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21064       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21065       do k=1,3
21066         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21067         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21068       enddo
21069       do k=1,3
21070         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21071       enddo
21072       do k=1,3
21073         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21074                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21075                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21076         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21077                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21078                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21079       enddo
21080 !C
21081 !C Calculate the components of the gradient in DC and X
21082 !C
21083       do l=1,3
21084         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21085         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21086       enddo
21087       return
21088       end subroutine sc_grad_nucl
21089 !-----------------------------------------------------------------------
21090       subroutine esb(esbloc)
21091 !C Calculate the local energy of a side chain and its derivatives in the
21092 !C corresponding virtual-bond valence angles THETA and the spherical angles
21093 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21094 !C added by Urszula Kozlowska. 07/11/2007
21095 !C
21096       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21097       real(kind=8),dimension(9):: x
21098      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21099       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21100       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21101       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21102        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21103        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21104        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21105        integer::it,nlobit,i,j,k
21106 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21107       delta=0.02d0*pi
21108       esbloc=0.0D0
21109       do i=loc_start_nucl,loc_end_nucl
21110         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21111         costtab(i+1) =dcos(theta(i+1))
21112         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21113         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21114         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21115         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21116         cosfac=dsqrt(cosfac2)
21117         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21118         sinfac=dsqrt(sinfac2)
21119         it=itype(i,2)
21120         if (it.eq.10) goto 1
21121
21122 !c
21123 !C  Compute the axes of tghe local cartesian coordinates system; store in
21124 !c   x_prime, y_prime and z_prime
21125 !c
21126         do j=1,3
21127           x_prime(j) = 0.00
21128           y_prime(j) = 0.00
21129           z_prime(j) = 0.00
21130         enddo
21131 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21132 !C     &   dc_norm(3,i+nres)
21133         do j = 1,3
21134           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21135           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21136         enddo
21137         do j = 1,3
21138           z_prime(j) = -uz(j,i-1)
21139 !           z_prime(j)=0.0
21140         enddo
21141
21142         xx=0.0d0
21143         yy=0.0d0
21144         zz=0.0d0
21145         do j = 1,3
21146           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21147           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21148           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21149         enddo
21150
21151         xxtab(i)=xx
21152         yytab(i)=yy
21153         zztab(i)=zz
21154          it=itype(i,2)
21155         do j = 1,9
21156           x(j) = sc_parmin_nucl(j,it)
21157         enddo
21158 #ifdef CHECK_COORD
21159 !Cc diagnostics - remove later
21160         xx1 = dcos(alph(2))
21161         yy1 = dsin(alph(2))*dcos(omeg(2))
21162         zz1 = -dsin(alph(2))*dsin(omeg(2))
21163         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21164          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21165          xx1,yy1,zz1
21166 !C,"  --- ", xx_w,yy_w,zz_w
21167 !c end diagnostics
21168 #endif
21169         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21170         esbloc = esbloc + sumene
21171         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21172 !        print *,"enecomp",sumene,sumene2
21173 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21174 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21175 #ifdef DEBUG
21176         write (2,*) "x",(x(k),k=1,9)
21177 !C
21178 !C This section to check the numerical derivatives of the energy of ith side
21179 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21180 !C #define DEBUG in the code to turn it on.
21181 !C
21182         write (2,*) "sumene               =",sumene
21183         aincr=1.0d-7
21184         xxsave=xx
21185         xx=xx+aincr
21186         write (2,*) xx,yy,zz
21187         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21188         de_dxx_num=(sumenep-sumene)/aincr
21189         xx=xxsave
21190         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21191         yysave=yy
21192         yy=yy+aincr
21193         write (2,*) xx,yy,zz
21194         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21195         de_dyy_num=(sumenep-sumene)/aincr
21196         yy=yysave
21197         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21198         zzsave=zz
21199         zz=zz+aincr
21200         write (2,*) xx,yy,zz
21201         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21202         de_dzz_num=(sumenep-sumene)/aincr
21203         zz=zzsave
21204         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21205         costsave=cost2tab(i+1)
21206         sintsave=sint2tab(i+1)
21207         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21208         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21209         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21210         de_dt_num=(sumenep-sumene)/aincr
21211         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21212         cost2tab(i+1)=costsave
21213         sint2tab(i+1)=sintsave
21214 !C End of diagnostics section.
21215 #endif
21216 !C
21217 !C Compute the gradient of esc
21218 !C
21219         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21220         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21221         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21222         de_dtt=0.0d0
21223 #ifdef DEBUG
21224         write (2,*) "x",(x(k),k=1,9)
21225         write (2,*) "xx",xx," yy",yy," zz",zz
21226         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21227           " de_zz   ",de_zz," de_tt   ",de_tt
21228         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21229           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21230 #endif
21231 !C
21232        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21233        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21234        cosfac2xx=cosfac2*xx
21235        sinfac2yy=sinfac2*yy
21236        do k = 1,3
21237          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21238            vbld_inv(i+1)
21239          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21240            vbld_inv(i)
21241          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21242          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21243 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21244 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21245 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21246 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21247          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21248          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21249          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21250          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21251          dZZ_Ci1(k)=0.0d0
21252          dZZ_Ci(k)=0.0d0
21253          do j=1,3
21254            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21255            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21256          enddo
21257
21258          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21259          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21260          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21261 !c
21262          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21263          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21264        enddo
21265
21266        do k=1,3
21267          dXX_Ctab(k,i)=dXX_Ci(k)
21268          dXX_C1tab(k,i)=dXX_Ci1(k)
21269          dYY_Ctab(k,i)=dYY_Ci(k)
21270          dYY_C1tab(k,i)=dYY_Ci1(k)
21271          dZZ_Ctab(k,i)=dZZ_Ci(k)
21272          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21273          dXX_XYZtab(k,i)=dXX_XYZ(k)
21274          dYY_XYZtab(k,i)=dYY_XYZ(k)
21275          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21276        enddo
21277        do k = 1,3
21278 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21279 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21280 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21281 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21282 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21283 !c     &    dt_dci(k)
21284 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21285 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21286          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21287          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21288          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21289          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21290          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21291          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21292 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21293        enddo
21294 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21295 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21296
21297 !C to check gradient call subroutine check_grad
21298
21299     1 continue
21300       enddo
21301       return
21302       end subroutine esb
21303 !=-------------------------------------------------------
21304       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21305 !      implicit none
21306       real(kind=8),dimension(9):: x(9)
21307        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21308       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21309       integer i
21310 !c      write (2,*) "enesc"
21311 !c      write (2,*) "x",(x(i),i=1,9)
21312 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21313       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21314         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21315         + x(9)*yy*zz
21316       enesc_nucl=sumene
21317       return
21318       end function enesc_nucl
21319 !-----------------------------------------------------------------------------
21320       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21321 #ifdef MPI
21322       include 'mpif.h'
21323       integer,parameter :: max_cont=2000
21324       integer,parameter:: max_dim=2*(8*3+6)
21325       integer, parameter :: msglen1=max_cont*max_dim
21326       integer,parameter :: msglen2=2*msglen1
21327       integer source,CorrelType,CorrelID,Error
21328       real(kind=8) :: buffer(max_cont,max_dim)
21329       integer status(MPI_STATUS_SIZE)
21330       integer :: ierror,nbytes
21331 #endif
21332       real(kind=8),dimension(3):: gx(3),gx1(3)
21333       real(kind=8) :: time00
21334       logical lprn,ldone
21335       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21336       real(kind=8) ecorr,ecorr3
21337       integer :: n_corr,n_corr1,mm,msglen
21338 !C Set lprn=.true. for debugging
21339       lprn=.false.
21340       n_corr=0
21341       n_corr1=0
21342 #ifdef MPI
21343       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21344
21345       if (nfgtasks.le.1) goto 30
21346       if (lprn) then
21347         write (iout,'(a)') 'Contact function values:'
21348         do i=nnt,nct-1
21349           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21350          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21351          j=1,num_cont_hb(i))
21352         enddo
21353       endif
21354 !C Caution! Following code assumes that electrostatic interactions concerning
21355 !C a given atom are split among at most two processors!
21356       CorrelType=477
21357       CorrelID=fg_rank+1
21358       ldone=.false.
21359       do i=1,max_cont
21360         do j=1,max_dim
21361           buffer(i,j)=0.0D0
21362         enddo
21363       enddo
21364       mm=mod(fg_rank,2)
21365 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21366       if (mm) 20,20,10
21367    10 continue
21368 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21369       if (fg_rank.gt.0) then
21370 !C Send correlation contributions to the preceding processor
21371         msglen=msglen1
21372         nn=num_cont_hb(iatel_s_nucl)
21373         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21374 !c        write (*,*) 'The BUFFER array:'
21375 !c        do i=1,nn
21376 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21377 !c        enddo
21378         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21379           msglen=msglen2
21380           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21381 !C Clear the contacts of the atom passed to the neighboring processor
21382         nn=num_cont_hb(iatel_s_nucl+1)
21383 !c        do i=1,nn
21384 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21385 !c        enddo
21386             num_cont_hb(iatel_s_nucl)=0
21387         endif
21388 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21389 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21390 !cd   & ' msglen=',msglen
21391 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21392 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21393 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21394         time00=MPI_Wtime()
21395         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21396          CorrelType,FG_COMM,IERROR)
21397         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21398 !cd      write (iout,*) 'Processor ',fg_rank,
21399 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21400 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21401 !c        write (*,*) 'Processor ',fg_rank,
21402 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21403 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21404 !c        msglen=msglen1
21405       endif ! (fg_rank.gt.0)
21406       if (ldone) goto 30
21407       ldone=.true.
21408    20 continue
21409 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21410       if (fg_rank.lt.nfgtasks-1) then
21411 !C Receive correlation contributions from the next processor
21412         msglen=msglen1
21413         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21414 !cd      write (iout,*) 'Processor',fg_rank,
21415 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21416 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21417 !c        write (*,*) 'Processor',fg_rank,
21418 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21419 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21420         time00=MPI_Wtime()
21421         nbytes=-1
21422         do while (nbytes.le.0)
21423           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21424           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21425         enddo
21426 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21427         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21428          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21429         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21430 !c        write (*,*) 'Processor',fg_rank,
21431 !c     &' has received correlation contribution from processor',fg_rank+1,
21432 !c     & ' msglen=',msglen,' nbytes=',nbytes
21433 !c        write (*,*) 'The received BUFFER array:'
21434 !c        do i=1,max_cont
21435 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21436 !c        enddo
21437         if (msglen.eq.msglen1) then
21438           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21439         else if (msglen.eq.msglen2)  then
21440           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21441           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21442         else
21443           write (iout,*) &
21444       'ERROR!!!! message length changed while processing correlations.'
21445           write (*,*) &
21446       'ERROR!!!! message length changed while processing correlations.'
21447           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21448         endif ! msglen.eq.msglen1
21449       endif ! fg_rank.lt.nfgtasks-1
21450       if (ldone) goto 30
21451       ldone=.true.
21452       goto 10
21453    30 continue
21454 #endif
21455       if (lprn) then
21456         write (iout,'(a)') 'Contact function values:'
21457         do i=nnt_molec(2),nct_molec(2)-1
21458           write (iout,'(2i3,50(1x,i2,f5.2))') &
21459          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21460          j=1,num_cont_hb(i))
21461         enddo
21462       endif
21463       ecorr=0.0D0
21464       ecorr3=0.0d0
21465 !C Remove the loop below after debugging !!!
21466 !      do i=nnt_molec(2),nct_molec(2)
21467 !        do j=1,3
21468 !          gradcorr_nucl(j,i)=0.0D0
21469 !          gradxorr_nucl(j,i)=0.0D0
21470 !          gradcorr3_nucl(j,i)=0.0D0
21471 !          gradxorr3_nucl(j,i)=0.0D0
21472 !        enddo
21473 !      enddo
21474 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21475 !C Calculate the local-electrostatic correlation terms
21476       do i=iatsc_s_nucl,iatsc_e_nucl
21477         i1=i+1
21478         num_conti=num_cont_hb(i)
21479         num_conti1=num_cont_hb(i+1)
21480 !        print *,i,num_conti,num_conti1
21481         do jj=1,num_conti
21482           j=jcont_hb(jj,i)
21483           do kk=1,num_conti1
21484             j1=jcont_hb(kk,i1)
21485 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21486 !c     &         ' jj=',jj,' kk=',kk
21487             if (j1.eq.j+1 .or. j1.eq.j-1) then
21488 !C
21489 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21490 !C The system gains extra energy.
21491 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21492 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21493 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21494 !C
21495               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21496               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21497                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21498               n_corr=n_corr+1
21499             else if (j1.eq.j) then
21500 !C
21501 !C Contacts I-J and I-(J+1) occur simultaneously.
21502 !C The system loses extra energy.
21503 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21504 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21505 !C Need to implement full formulas 32 from Liwo et al., 1998.
21506 !C
21507 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21508 !c     &         ' jj=',jj,' kk=',kk
21509               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21510             endif
21511           enddo ! kk
21512           do kk=1,num_conti
21513             j1=jcont_hb(kk,i)
21514 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21515 !c     &         ' jj=',jj,' kk=',kk
21516             if (j1.eq.j+1) then
21517 !C Contacts I-J and (I+1)-J occur simultaneously.
21518 !C The system loses extra energy.
21519               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21520             endif ! j1==j+1
21521           enddo ! kk
21522         enddo ! jj
21523       enddo ! i
21524       return
21525       end subroutine multibody_hb_nucl
21526 !-----------------------------------------------------------
21527       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21528 !      implicit real*8 (a-h,o-z)
21529 !      include 'DIMENSIONS'
21530 !      include 'COMMON.IOUNITS'
21531 !      include 'COMMON.DERIV'
21532 !      include 'COMMON.INTERACT'
21533 !      include 'COMMON.CONTACTS'
21534       real(kind=8),dimension(3) :: gx,gx1
21535       logical :: lprn
21536 !el local variables
21537       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21538       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21539                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21540                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21541                    rlocshield
21542
21543       lprn=.false.
21544       eij=facont_hb(jj,i)
21545       ekl=facont_hb(kk,k)
21546       ees0pij=ees0p(jj,i)
21547       ees0pkl=ees0p(kk,k)
21548       ees0mij=ees0m(jj,i)
21549       ees0mkl=ees0m(kk,k)
21550       ekont=eij*ekl
21551       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21552 !      print *,"ehbcorr_nucl",ekont,ees
21553 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21554 !C Following 4 lines for diagnostics.
21555 !cd    ees0pkl=0.0D0
21556 !cd    ees0pij=1.0D0
21557 !cd    ees0mkl=0.0D0
21558 !cd    ees0mij=1.0D0
21559 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21560 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21561 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21562 !C Calculate the multi-body contribution to energy.
21563 !      ecorr_nucl=ecorr_nucl+ekont*ees
21564 !C Calculate multi-body contributions to the gradient.
21565       coeffpees0pij=coeffp*ees0pij
21566       coeffmees0mij=coeffm*ees0mij
21567       coeffpees0pkl=coeffp*ees0pkl
21568       coeffmees0mkl=coeffm*ees0mkl
21569       do ll=1,3
21570         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21571        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21572        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21573         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21574         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21575         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21576         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21577         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21578         coeffmees0mij*gacontm_hb1(ll,kk,k))
21579         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21580         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21581         coeffmees0mij*gacontm_hb2(ll,kk,k))
21582         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21583           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21584           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21585         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21586         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21587         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21588           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21589           coeffmees0mij*gacontm_hb3(ll,kk,k))
21590         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21591         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21592         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21593         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21594         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21595         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21596       enddo
21597       ehbcorr_nucl=ekont*ees
21598       return
21599       end function ehbcorr_nucl
21600 !-------------------------------------------------------------------------
21601
21602      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21603 !      implicit real*8 (a-h,o-z)
21604 !      include 'DIMENSIONS'
21605 !      include 'COMMON.IOUNITS'
21606 !      include 'COMMON.DERIV'
21607 !      include 'COMMON.INTERACT'
21608 !      include 'COMMON.CONTACTS'
21609       real(kind=8),dimension(3) :: gx,gx1
21610       logical :: lprn
21611 !el local variables
21612       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21613       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21614                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21615                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21616                    rlocshield
21617
21618       lprn=.false.
21619       eij=facont_hb(jj,i)
21620       ekl=facont_hb(kk,k)
21621       ees0pij=ees0p(jj,i)
21622       ees0pkl=ees0p(kk,k)
21623       ees0mij=ees0m(jj,i)
21624       ees0mkl=ees0m(kk,k)
21625       ekont=eij*ekl
21626       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21627 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21628 !C Following 4 lines for diagnostics.
21629 !cd    ees0pkl=0.0D0
21630 !cd    ees0pij=1.0D0
21631 !cd    ees0mkl=0.0D0
21632 !cd    ees0mij=1.0D0
21633 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21634 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21635 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21636 !C Calculate the multi-body contribution to energy.
21637 !      ecorr=ecorr+ekont*ees
21638 !C Calculate multi-body contributions to the gradient.
21639       coeffpees0pij=coeffp*ees0pij
21640       coeffmees0mij=coeffm*ees0mij
21641       coeffpees0pkl=coeffp*ees0pkl
21642       coeffmees0mkl=coeffm*ees0mkl
21643       do ll=1,3
21644         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21645        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21646        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21647         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21648         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21649         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21650         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21651         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21652         coeffmees0mij*gacontm_hb1(ll,kk,k))
21653         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21654         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21655         coeffmees0mij*gacontm_hb2(ll,kk,k))
21656         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21657           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21658           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21659         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21660         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21661         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21662           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21663           coeffmees0mij*gacontm_hb3(ll,kk,k))
21664         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21665         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21666         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21667         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21668         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21669         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21670       enddo
21671       ehbcorr3_nucl=ekont*ees
21672       return
21673       end function ehbcorr3_nucl
21674 #ifdef MPI
21675       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21676       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21677       real(kind=8):: buffer(dimen1,dimen2)
21678       num_kont=num_cont_hb(atom)
21679       do i=1,num_kont
21680         do k=1,8
21681           do j=1,3
21682             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21683           enddo ! j
21684         enddo ! k
21685         buffer(i,indx+25)=facont_hb(i,atom)
21686         buffer(i,indx+26)=ees0p(i,atom)
21687         buffer(i,indx+27)=ees0m(i,atom)
21688         buffer(i,indx+28)=d_cont(i,atom)
21689         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21690       enddo ! i
21691       buffer(1,indx+30)=dfloat(num_kont)
21692       return
21693       end subroutine pack_buffer
21694 !c------------------------------------------------------------------------------
21695       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21696       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21697       real(kind=8):: buffer(dimen1,dimen2)
21698 !      double precision zapas
21699 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21700 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21701 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21702 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21703       num_kont=buffer(1,indx+30)
21704       num_kont_old=num_cont_hb(atom)
21705       num_cont_hb(atom)=num_kont+num_kont_old
21706       do i=1,num_kont
21707         ii=i+num_kont_old
21708         do k=1,8
21709           do j=1,3
21710             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21711           enddo ! j
21712         enddo ! k
21713         facont_hb(ii,atom)=buffer(i,indx+25)
21714         ees0p(ii,atom)=buffer(i,indx+26)
21715         ees0m(ii,atom)=buffer(i,indx+27)
21716         d_cont(i,atom)=buffer(i,indx+28)
21717         jcont_hb(ii,atom)=buffer(i,indx+29)
21718       enddo ! i
21719       return
21720       end subroutine unpack_buffer
21721 !c------------------------------------------------------------------------------
21722 #endif
21723       subroutine ecatcat(ecationcation)
21724         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21725         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21726         r7,r4,ecationcation,k0,rcal
21727         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21728         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21729         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21730         gg,r
21731
21732         ecationcation=0.0d0
21733         if (nres_molec(5).eq.0) return
21734         rcat0=3.472
21735         epscalc=0.05
21736         r06 = rcat0**6
21737         r012 = r06**2
21738         k0 = 332.0*(2.0*2.0)/80.0
21739         itmp=0
21740         do i=1,4
21741         itmp=itmp+nres_molec(i)
21742         enddo
21743         do i=itmp+1,itmp+nres_molec(i)-1
21744
21745         xi=c(1,i)
21746         yi=c(2,i)
21747         zi=c(3,i)
21748           xi=mod(xi,boxxsize)
21749           if (xi.lt.0) xi=xi+boxxsize
21750           yi=mod(yi,boxysize)
21751           if (yi.lt.0) yi=yi+boxysize
21752           zi=mod(zi,boxzsize)
21753           if (zi.lt.0) zi=zi+boxzsize
21754
21755           do j=i+1,itmp+nres_molec(5)
21756 !           print *,i,j,'catcat'
21757            xj=c(1,j)
21758            yj=c(2,j)
21759            zj=c(3,j)
21760           xj=dmod(xj,boxxsize)
21761           if (xj.lt.0) xj=xj+boxxsize
21762           yj=dmod(yj,boxysize)
21763           if (yj.lt.0) yj=yj+boxysize
21764           zj=dmod(zj,boxzsize)
21765           if (zj.lt.0) zj=zj+boxzsize
21766       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21767       xj_safe=xj
21768       yj_safe=yj
21769       zj_safe=zj
21770       subchap=0
21771       do xshift=-1,1
21772       do yshift=-1,1
21773       do zshift=-1,1
21774           xj=xj_safe+xshift*boxxsize
21775           yj=yj_safe+yshift*boxysize
21776           zj=zj_safe+zshift*boxzsize
21777           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21778           if(dist_temp.lt.dist_init) then
21779             dist_init=dist_temp
21780             xj_temp=xj
21781             yj_temp=yj
21782             zj_temp=zj
21783             subchap=1
21784           endif
21785        enddo
21786        enddo
21787        enddo
21788        if (subchap.eq.1) then
21789           xj=xj_temp-xi
21790           yj=yj_temp-yi
21791           zj=zj_temp-zi
21792        else
21793           xj=xj_safe-xi
21794           yj=yj_safe-yi
21795           zj=zj_safe-zi
21796        endif
21797        rcal =xj**2+yj**2+zj**2
21798         ract=sqrt(rcal)
21799 !        rcat0=3.472
21800 !        epscalc=0.05
21801 !        r06 = rcat0**6
21802 !        r012 = r06**2
21803 !        k0 = 332*(2*2)/80
21804         Evan1cat=epscalc*(r012/rcal**6)
21805         Evan2cat=epscalc*2*(r06/rcal**3)
21806         Eeleccat=k0/ract
21807         r7 = rcal**7
21808         r4 = rcal**4
21809         r(1)=xj
21810         r(2)=yj
21811         r(3)=zj
21812         do k=1,3
21813           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21814           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21815           dEeleccat(k)=-k0*r(k)/ract**3
21816         enddo
21817         do k=1,3
21818           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21819           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
21820           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
21821         enddo
21822
21823         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
21824        enddo
21825        enddo
21826        return
21827        end subroutine ecatcat
21828 !---------------------------------------------------------------------------
21829        subroutine ecat_prot(ecation_prot)
21830        integer i,j,k,subchap,itmp,inum
21831         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21832         r7,r4,ecationcation
21833         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21834         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
21835         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
21836         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
21837         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
21838         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
21839         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
21840         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
21841         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
21842         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
21843         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
21844         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21845         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
21846         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
21847         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
21848         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
21849         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
21850         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
21851         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
21852         dEvan1Cat
21853         real(kind=8),dimension(6) :: vcatprm
21854         ecation_prot=0.0d0
21855 ! first lets calculate interaction with peptide groups
21856         if (nres_molec(5).eq.0) return
21857          wconst=78
21858         wdip =1.092777950857032D2
21859         wdip=wdip/wconst
21860         wmodquad=-2.174122713004870D4
21861         wmodquad=wmodquad/wconst
21862         wquad1 = 3.901232068562804D1
21863         wquad1=wquad1/wconst
21864         wquad2 = 3
21865         wquad2=wquad2/wconst
21866         wvan1 = 0.1
21867         wvan2 = 6
21868         itmp=0
21869         do i=1,4
21870         itmp=itmp+nres_molec(i)
21871         enddo
21872         do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
21873 !         cycle
21874          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
21875         xi=0.5d0*(c(1,i)+c(1,i+1))
21876         yi=0.5d0*(c(2,i)+c(2,i+1))
21877         zi=0.5d0*(c(3,i)+c(3,i+1))
21878           xi=mod(xi,boxxsize)
21879           if (xi.lt.0) xi=xi+boxxsize
21880           yi=mod(yi,boxysize)
21881           if (yi.lt.0) yi=yi+boxysize
21882           zi=mod(zi,boxzsize)
21883           if (zi.lt.0) zi=zi+boxzsize
21884
21885          do j=itmp+1,itmp+nres_molec(5)
21886            xj=c(1,j)
21887            yj=c(2,j)
21888            zj=c(3,j)
21889           xj=dmod(xj,boxxsize)
21890           if (xj.lt.0) xj=xj+boxxsize
21891           yj=dmod(yj,boxysize)
21892           if (yj.lt.0) yj=yj+boxysize
21893           zj=dmod(zj,boxzsize)
21894           if (zj.lt.0) zj=zj+boxzsize
21895       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21896       xj_safe=xj
21897       yj_safe=yj
21898       zj_safe=zj
21899       subchap=0
21900       do xshift=-1,1
21901       do yshift=-1,1
21902       do zshift=-1,1
21903           xj=xj_safe+xshift*boxxsize
21904           yj=yj_safe+yshift*boxysize
21905           zj=zj_safe+zshift*boxzsize
21906           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21907           if(dist_temp.lt.dist_init) then
21908             dist_init=dist_temp
21909             xj_temp=xj
21910             yj_temp=yj
21911             zj_temp=zj
21912             subchap=1
21913           endif
21914        enddo
21915        enddo
21916        enddo
21917        if (subchap.eq.1) then
21918           xj=xj_temp-xi
21919           yj=yj_temp-yi
21920           zj=zj_temp-zi
21921        else
21922           xj=xj_safe-xi
21923           yj=yj_safe-yi
21924           zj=zj_safe-zi
21925        endif
21926 !       enddo
21927 !       enddo
21928        rcpm = sqrt(xj**2+yj**2+zj**2)
21929        drcp_norm(1)=xj/rcpm
21930        drcp_norm(2)=yj/rcpm
21931        drcp_norm(3)=zj/rcpm
21932        dcmag=0.0
21933        do k=1,3
21934        dcmag=dcmag+dc(k,i)**2
21935        enddo
21936        dcmag=dsqrt(dcmag)
21937        do k=1,3
21938          myd_norm(k)=dc(k,i)/dcmag
21939        enddo
21940         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
21941         drcp_norm(3)*myd_norm(3)
21942         rsecp = rcpm**2
21943         Ir = 1.0d0/rcpm
21944         Irsecp = 1.0d0/rsecp
21945         Irthrp = Irsecp/rcpm
21946         Irfourp = Irthrp/rcpm
21947         Irfiftp = Irfourp/rcpm
21948         Irsistp=Irfiftp/rcpm
21949         Irseven=Irsistp/rcpm
21950         Irtwelv=Irsistp*Irsistp
21951         Irthir=Irtwelv/rcpm
21952         sin2thet = (1-costhet*costhet)
21953         sinthet=sqrt(sin2thet)
21954         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
21955              *sin2thet
21956         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
21957              2*wvan2**6*Irsistp)
21958         ecation_prot = ecation_prot+E1+E2
21959         dE1dr = -2*costhet*wdip*Irthrp-&
21960          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
21961         dE2dr = 3*wquad1*wquad2*Irfourp-     &
21962           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
21963         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
21964         do k=1,3
21965           drdpep(k) = -drcp_norm(k)
21966           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
21967           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
21968           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
21969           dEddci(k) = dEdcos*dcosddci(k)
21970         enddo
21971         do k=1,3
21972         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
21973         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
21974         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
21975         enddo
21976        enddo ! j
21977        enddo ! i
21978 !------------------------------------------sidechains
21979         do i=1,nres_molec(1)
21980          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
21981 !         cycle
21982 !        print *,i,ecation_prot
21983         xi=(c(1,i+nres))
21984         yi=(c(2,i+nres))
21985         zi=(c(3,i+nres))
21986           xi=mod(xi,boxxsize)
21987           if (xi.lt.0) xi=xi+boxxsize
21988           yi=mod(yi,boxysize)
21989           if (yi.lt.0) yi=yi+boxysize
21990           zi=mod(zi,boxzsize)
21991           if (zi.lt.0) zi=zi+boxzsize
21992           do k=1,3
21993             cm1(k)=dc(k,i+nres)
21994           enddo
21995            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
21996          do j=itmp+1,itmp+nres_molec(5)
21997            xj=c(1,j)
21998            yj=c(2,j)
21999            zj=c(3,j)
22000           xj=dmod(xj,boxxsize)
22001           if (xj.lt.0) xj=xj+boxxsize
22002           yj=dmod(yj,boxysize)
22003           if (yj.lt.0) yj=yj+boxysize
22004           zj=dmod(zj,boxzsize)
22005           if (zj.lt.0) zj=zj+boxzsize
22006       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22007       xj_safe=xj
22008       yj_safe=yj
22009       zj_safe=zj
22010       subchap=0
22011       do xshift=-1,1
22012       do yshift=-1,1
22013       do zshift=-1,1
22014           xj=xj_safe+xshift*boxxsize
22015           yj=yj_safe+yshift*boxysize
22016           zj=zj_safe+zshift*boxzsize
22017           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22018           if(dist_temp.lt.dist_init) then
22019             dist_init=dist_temp
22020             xj_temp=xj
22021             yj_temp=yj
22022             zj_temp=zj
22023             subchap=1
22024           endif
22025        enddo
22026        enddo
22027        enddo
22028        if (subchap.eq.1) then
22029           xj=xj_temp-xi
22030           yj=yj_temp-yi
22031           zj=zj_temp-zi
22032        else
22033           xj=xj_safe-xi
22034           yj=yj_safe-yi
22035           zj=zj_safe-zi
22036        endif
22037 !       enddo
22038 !       enddo
22039          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22040             if(itype(i,1).eq.16) then
22041             inum=1
22042             else
22043             inum=2
22044             endif
22045             do k=1,6
22046             vcatprm(k)=catprm(k,inum)
22047             enddo
22048             dASGL=catprm(7,inum)
22049              do k=1,3
22050                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22051                 valpha(k)=c(k,i)
22052                 vcat(k)=c(k,j)
22053               enddo
22054                       do k=1,3
22055           dx(k) = vcat(k)-vcm(k)
22056         enddo
22057         do k=1,3
22058           v1(k)=(vcm(k)-valpha(k))
22059           v2(k)=(vcat(k)-valpha(k))
22060         enddo
22061         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22062         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22063         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22064
22065 !  The weights of the energy function calculated from
22066 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22067         wh2o=78
22068         wc = vcatprm(1)
22069         wc=wc/wh2o
22070         wdip =vcatprm(2)
22071         wdip=wdip/wh2o
22072         wquad1 =vcatprm(3)
22073         wquad1=wquad1/wh2o
22074         wquad2 = vcatprm(4)
22075         wquad2=wquad2/wh2o
22076         wquad2p = 1-wquad2
22077         wvan1 = vcatprm(5)
22078         wvan2 =vcatprm(6)
22079         opt = dx(1)**2+dx(2)**2
22080         rsecp = opt+dx(3)**2
22081         rs = sqrt(rsecp)
22082         rthrp = rsecp*rs
22083         rfourp = rthrp*rs
22084         rsixp = rfourp*rsecp
22085         reight=rsixp*rsecp
22086         Ir = 1.0d0/rs
22087         Irsecp = 1/rsecp
22088         Irthrp = Irsecp/rs
22089         Irfourp = Irthrp/rs
22090         Irsixp = 1/rsixp
22091         Ireight=1/reight
22092         Irtw=Irsixp*Irsixp
22093         Irthir=Irtw/rs
22094         Irfourt=Irthir/rs
22095         opt1 = (4*rs*dx(3)*wdip)
22096         opt2 = 6*rsecp*wquad1*opt
22097         opt3 = wquad1*wquad2p*Irsixp
22098         opt4 = (wvan1*wvan2**12)
22099         opt5 = opt4*12*Irfourt
22100         opt6 = 2*wvan1*wvan2**6
22101         opt7 = 6*opt6*Ireight
22102         opt8 = wdip/v1m
22103         opt10 = wdip/v2m
22104         opt11 = (rsecp*v2m)**2
22105         opt12 = (rsecp*v1m)**2
22106         opt14 = (v1m*v2m*rsecp)**2
22107         opt15 = -wquad1/v2m**2
22108         opt16 = (rthrp*(v1m*v2m)**2)**2
22109         opt17 = (v1m**2*rthrp)**2
22110         opt18 = -wquad1/rthrp
22111         opt19 = (v1m**2*v2m**2)**2
22112         Ec = wc*Ir
22113         do k=1,3
22114           dEcCat(k) = -(dx(k)*wc)*Irthrp
22115           dEcCm(k)=(dx(k)*wc)*Irthrp
22116           dEcCalp(k)=0.0d0
22117         enddo
22118         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22119         do k=1,3
22120           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22121                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22122           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22123                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22124           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22125                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22126                       *v1dpv2)/opt14
22127         enddo
22128         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22129         do k=1,3
22130           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22131                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22132                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22133           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22134                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22135                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22136           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22137                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22138                         v1dpv2**2)/opt19
22139         enddo
22140         Equad2=wquad1*wquad2p*Irthrp
22141         do k=1,3
22142           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22143           dEquad2Cm(k)=3*dx(k)*rs*opt3
22144           dEquad2Calp(k)=0.0d0
22145         enddo
22146         Evan1=opt4*Irtw
22147         do k=1,3
22148           dEvan1Cat(k)=-dx(k)*opt5
22149           dEvan1Cm(k)=dx(k)*opt5
22150           dEvan1Calp(k)=0.0d0
22151         enddo
22152         Evan2=-opt6*Irsixp
22153         do k=1,3
22154           dEvan2Cat(k)=dx(k)*opt7
22155           dEvan2Cm(k)=-dx(k)*opt7
22156           dEvan2Calp(k)=0.0d0
22157         enddo
22158         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22159 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22160
22161         do k=1,3
22162           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22163                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22164 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22165           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22166                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22167           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22168                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22169         enddo
22170             dscmag = 0.0d0
22171             do k=1,3
22172               dscvec(k) = dc(k,i+nres)
22173               dscmag = dscmag+dscvec(k)*dscvec(k)
22174             enddo
22175             dscmag3 = dscmag
22176             dscmag = sqrt(dscmag)
22177             dscmag3 = dscmag3*dscmag
22178             constA = 1.0d0+dASGL/dscmag
22179             constB = 0.0d0
22180             do k=1,3
22181               constB = constB+dscvec(k)*dEtotalCm(k)
22182             enddo
22183             constB = constB*dASGL/dscmag3
22184             do k=1,3
22185               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22186               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22187                constA*dEtotalCm(k)-constB*dscvec(k)
22188 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22189               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22190               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22191              enddo
22192         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22193            if(itype(i,1).eq.14) then
22194             inum=3
22195             else
22196             inum=4
22197             endif
22198             do k=1,6
22199             vcatprm(k)=catprm(k,inum)
22200             enddo
22201             dASGL=catprm(7,inum)
22202              do k=1,3
22203                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22204                 valpha(k)=c(k,i)
22205                 vcat(k)=c(k,j)
22206               enddo
22207
22208         do k=1,3
22209           dx(k) = vcat(k)-vcm(k)
22210         enddo
22211         do k=1,3
22212           v1(k)=(vcm(k)-valpha(k))
22213           v2(k)=(vcat(k)-valpha(k))
22214         enddo
22215         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22216         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22217         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22218 !  The weights of the energy function calculated from
22219 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22220         wh2o=78
22221         wdip =vcatprm(2)
22222         wdip=wdip/wh2o
22223         wquad1 =vcatprm(3)
22224         wquad1=wquad1/wh2o
22225         wquad2 = vcatprm(4)
22226         wquad2=wquad2/wh2o
22227         wquad2p = 1-wquad2
22228         wvan1 = vcatprm(5)
22229         wvan2 =vcatprm(6)
22230         opt = dx(1)**2+dx(2)**2
22231         rsecp = opt+dx(3)**2
22232         rs = sqrt(rsecp)
22233         rthrp = rsecp*rs
22234         rfourp = rthrp*rs
22235         rsixp = rfourp*rsecp
22236         reight=rsixp*rsecp
22237         Ir = 1.0d0/rs
22238         Irsecp = 1/rsecp
22239         Irthrp = Irsecp/rs
22240         Irfourp = Irthrp/rs
22241         Irsixp = 1/rsixp
22242         Ireight=1/reight
22243         Irtw=Irsixp*Irsixp
22244         Irthir=Irtw/rs
22245         Irfourt=Irthir/rs
22246         opt1 = (4*rs*dx(3)*wdip)
22247         opt2 = 6*rsecp*wquad1*opt
22248         opt3 = wquad1*wquad2p*Irsixp
22249         opt4 = (wvan1*wvan2**12)
22250         opt5 = opt4*12*Irfourt
22251         opt6 = 2*wvan1*wvan2**6
22252         opt7 = 6*opt6*Ireight
22253         opt8 = wdip/v1m
22254         opt10 = wdip/v2m
22255         opt11 = (rsecp*v2m)**2
22256         opt12 = (rsecp*v1m)**2
22257         opt14 = (v1m*v2m*rsecp)**2
22258         opt15 = -wquad1/v2m**2
22259         opt16 = (rthrp*(v1m*v2m)**2)**2
22260         opt17 = (v1m**2*rthrp)**2
22261         opt18 = -wquad1/rthrp
22262         opt19 = (v1m**2*v2m**2)**2
22263         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22264         do k=1,3
22265           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22266                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22267          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22268                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22269           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22270                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22271                       *v1dpv2)/opt14
22272         enddo
22273         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22274         do k=1,3
22275           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22276                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22277                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22278           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22279                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22280                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22281           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22282                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22283                         v1dpv2**2)/opt19
22284         enddo
22285         Equad2=wquad1*wquad2p*Irthrp
22286         do k=1,3
22287           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22288           dEquad2Cm(k)=3*dx(k)*rs*opt3
22289           dEquad2Calp(k)=0.0d0
22290         enddo
22291         Evan1=opt4*Irtw
22292         do k=1,3
22293           dEvan1Cat(k)=-dx(k)*opt5
22294           dEvan1Cm(k)=dx(k)*opt5
22295           dEvan1Calp(k)=0.0d0
22296         enddo
22297         Evan2=-opt6*Irsixp
22298         do k=1,3
22299           dEvan2Cat(k)=dx(k)*opt7
22300           dEvan2Cm(k)=-dx(k)*opt7
22301           dEvan2Calp(k)=0.0d0
22302         enddo
22303          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22304         do k=1,3
22305           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22306                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22307           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22308                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22309           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22310                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22311         enddo
22312             dscmag = 0.0d0
22313             do k=1,3
22314               dscvec(k) = c(k,i+nres)-c(k,i)
22315               dscmag = dscmag+dscvec(k)*dscvec(k)
22316             enddo
22317             dscmag3 = dscmag
22318             dscmag = sqrt(dscmag)
22319             dscmag3 = dscmag3*dscmag
22320             constA = 1+dASGL/dscmag
22321             constB = 0.0d0
22322             do k=1,3
22323               constB = constB+dscvec(k)*dEtotalCm(k)
22324             enddo
22325             constB = constB*dASGL/dscmag3
22326             do k=1,3
22327               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22328               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22329                constA*dEtotalCm(k)-constB*dscvec(k)
22330               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22331               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22332              enddo
22333            else
22334             rcal = 0.0d0
22335             do k=1,3
22336               r(k) = c(k,j)-c(k,i+nres)
22337               rcal = rcal+r(k)*r(k)
22338             enddo
22339             ract=sqrt(rcal)
22340             rocal=1.5
22341             epscalc=0.2
22342             r0p=0.5*(rocal+sig0(itype(i,1)))
22343             r06 = r0p**6
22344             r012 = r06*r06
22345             Evan1=epscalc*(r012/rcal**6)
22346             Evan2=epscalc*2*(r06/rcal**3)
22347             r4 = rcal**4
22348             r7 = rcal**7
22349             do k=1,3
22350               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22351               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22352             enddo
22353             do k=1,3
22354               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22355             enddo
22356                  ecation_prot = ecation_prot+ Evan1+Evan2
22357             do  k=1,3
22358                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22359                dEtotalCm(k)
22360               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22361               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22362              enddo
22363          endif ! 13-16 residues
22364        enddo !j
22365        enddo !i
22366        return
22367        end subroutine ecat_prot
22368
22369 !----------------------------------------------------------------------------
22370 !-----------------------------------------------------------------------------
22371 !-----------------------------------------------------------------------------
22372       subroutine eprot_sc_base(escbase)
22373       use calc_data
22374 !      implicit real*8 (a-h,o-z)
22375 !      include 'DIMENSIONS'
22376 !      include 'COMMON.GEO'
22377 !      include 'COMMON.VAR'
22378 !      include 'COMMON.LOCAL'
22379 !      include 'COMMON.CHAIN'
22380 !      include 'COMMON.DERIV'
22381 !      include 'COMMON.NAMES'
22382 !      include 'COMMON.INTERACT'
22383 !      include 'COMMON.IOUNITS'
22384 !      include 'COMMON.CALC'
22385 !      include 'COMMON.CONTROL'
22386 !      include 'COMMON.SBRIDGE'
22387       logical :: lprn
22388 !el local variables
22389       integer :: iint,itypi,itypi1,itypj,subchap
22390       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22391       real(kind=8) :: evdw,sig0ij
22392       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22393                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22394                     sslipi,sslipj,faclip
22395       integer :: ii
22396       real(kind=8) :: fracinbuf
22397        real (kind=8) :: escbase
22398        real (kind=8),dimension(4):: ener
22399        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22400        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22401         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22402         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22403         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22404         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22405         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22406         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22407        real(kind=8),dimension(3,2)::chead,erhead_tail
22408        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22409        integer troll
22410        eps_out=80.0d0
22411        escbase=0.0d0
22412        do i=1,nres_molec(1)
22413         if (itype(i,1).eq.ntyp1_molec(1)) cycle
22414         itypi  = itype(i,1)
22415         dxi    = dc_norm(1,nres+i)
22416         dyi    = dc_norm(2,nres+i)
22417         dzi    = dc_norm(3,nres+i)
22418         dsci_inv = vbld_inv(i+nres)
22419         xi=c(1,nres+i)
22420         yi=c(2,nres+i)
22421         zi=c(3,nres+i)
22422         xi=mod(xi,boxxsize)
22423          if (xi.lt.0) xi=xi+boxxsize
22424         yi=mod(yi,boxysize)
22425          if (yi.lt.0) yi=yi+boxysize
22426         zi=mod(zi,boxzsize)
22427          if (zi.lt.0) zi=zi+boxzsize
22428          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22429            itypj= itype(j,2)
22430            if (itype(j,2).eq.ntyp1_molec(2))cycle
22431            xj=c(1,j+nres)
22432            yj=c(2,j+nres)
22433            zj=c(3,j+nres)
22434            xj=dmod(xj,boxxsize)
22435            if (xj.lt.0) xj=xj+boxxsize
22436            yj=dmod(yj,boxysize)
22437            if (yj.lt.0) yj=yj+boxysize
22438            zj=dmod(zj,boxzsize)
22439            if (zj.lt.0) zj=zj+boxzsize
22440           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22441           xj_safe=xj
22442           yj_safe=yj
22443           zj_safe=zj
22444           subchap=0
22445
22446           do xshift=-1,1
22447           do yshift=-1,1
22448           do zshift=-1,1
22449           xj=xj_safe+xshift*boxxsize
22450           yj=yj_safe+yshift*boxysize
22451           zj=zj_safe+zshift*boxzsize
22452           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22453           if(dist_temp.lt.dist_init) then
22454             dist_init=dist_temp
22455             xj_temp=xj
22456             yj_temp=yj
22457             zj_temp=zj
22458             subchap=1
22459           endif
22460           enddo
22461           enddo
22462           enddo
22463           if (subchap.eq.1) then
22464           xj=xj_temp-xi
22465           yj=yj_temp-yi
22466           zj=zj_temp-zi
22467           else
22468           xj=xj_safe-xi
22469           yj=yj_safe-yi
22470           zj=zj_safe-zi
22471           endif
22472           dxj = dc_norm( 1, nres+j )
22473           dyj = dc_norm( 2, nres+j )
22474           dzj = dc_norm( 3, nres+j )
22475 !          print *,i,j,itypi,itypj
22476           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
22477           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
22478 !          d1i=0.0d0
22479 !          d1j=0.0d0
22480 !          BetaT = 1.0d0 / (298.0d0 * Rb)
22481 ! Gay-berne var's
22482           sig0ij = sigma_scbase( itypi,itypj )
22483           chi1   = chi_scbase( itypi, itypj,1 )
22484           chi2   = chi_scbase( itypi, itypj,2 )
22485 !          chi1=0.0d0
22486 !          chi2=0.0d0
22487           chi12  = chi1 * chi2
22488           chip1  = chipp_scbase( itypi, itypj,1 )
22489           chip2  = chipp_scbase( itypi, itypj,2 )
22490 !          chip1=0.0d0
22491 !          chip2=0.0d0
22492           chip12 = chip1 * chip2
22493 ! not used by momo potential, but needed by sc_angular which is shared
22494 ! by all energy_potential subroutines
22495           alf1   = 0.0d0
22496           alf2   = 0.0d0
22497           alf12  = 0.0d0
22498           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
22499 !       a12sq = a12sq * a12sq
22500 ! charge of amino acid itypi is...
22501           chis1 = chis_scbase(itypi,itypj,1)
22502           chis2 = chis_scbase(itypi,itypj,2)
22503           chis12 = chis1 * chis2
22504           sig1 = sigmap1_scbase(itypi,itypj)
22505           sig2 = sigmap2_scbase(itypi,itypj)
22506 !       write (*,*) "sig1 = ", sig1
22507 !       write (*,*) "sig2 = ", sig2
22508 ! alpha factors from Fcav/Gcav
22509           b1 = alphasur_scbase(1,itypi,itypj)
22510 !          b1=0.0d0
22511           b2 = alphasur_scbase(2,itypi,itypj)
22512           b3 = alphasur_scbase(3,itypi,itypj)
22513           b4 = alphasur_scbase(4,itypi,itypj)
22514 ! used to determine whether we want to do quadrupole calculations
22515 ! used by Fgb
22516        eps_in = epsintab_scbase(itypi,itypj)
22517        if (eps_in.eq.0.0) eps_in=1.0
22518        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22519 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
22520 !-------------------------------------------------------------------
22521 ! tail location and distance calculations
22522        DO k = 1,3
22523 ! location of polar head is computed by taking hydrophobic centre
22524 ! and moving by a d1 * dc_norm vector
22525 ! see unres publications for very informative images
22526         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
22527         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
22528 ! distance
22529 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22530 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22531         Rhead_distance(k) = chead(k,2) - chead(k,1)
22532        END DO
22533 ! pitagoras (root of sum of squares)
22534        Rhead = dsqrt( &
22535           (Rhead_distance(1)*Rhead_distance(1)) &
22536         + (Rhead_distance(2)*Rhead_distance(2)) &
22537         + (Rhead_distance(3)*Rhead_distance(3)))
22538 !-------------------------------------------------------------------
22539 ! zero everything that should be zero'ed
22540        evdwij = 0.0d0
22541        ECL = 0.0d0
22542        Elj = 0.0d0
22543        Equad = 0.0d0
22544        Epol = 0.0d0
22545        Fcav=0.0d0
22546        eheadtail = 0.0d0
22547        dGCLdOM1 = 0.0d0
22548        dGCLdOM2 = 0.0d0
22549        dGCLdOM12 = 0.0d0
22550        dPOLdOM1 = 0.0d0
22551        dPOLdOM2 = 0.0d0
22552           Fcav = 0.0d0
22553           dFdR = 0.0d0
22554           dCAVdOM1  = 0.0d0
22555           dCAVdOM2  = 0.0d0
22556           dCAVdOM12 = 0.0d0
22557           dscj_inv = vbld_inv(j+nres)
22558 !          print *,i,j,dscj_inv,dsci_inv
22559 ! rij holds 1/(distance of Calpha atoms)
22560           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22561           rij  = dsqrt(rrij)
22562 !----------------------------
22563           CALL sc_angular
22564 ! this should be in elgrad_init but om's are calculated by sc_angular
22565 ! which in turn is used by older potentials
22566 ! om = omega, sqom = om^2
22567           sqom1  = om1 * om1
22568           sqom2  = om2 * om2
22569           sqom12 = om12 * om12
22570
22571 ! now we calculate EGB - Gey-Berne
22572 ! It will be summed up in evdwij and saved in evdw
22573           sigsq     = 1.0D0  / sigsq
22574           sig       = sig0ij * dsqrt(sigsq)
22575 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22576           rij_shift = 1.0/rij - sig + sig0ij
22577           IF (rij_shift.le.0.0D0) THEN
22578            evdw = 1.0D20
22579            RETURN
22580           END IF
22581           sigder = -sig * sigsq
22582           rij_shift = 1.0D0 / rij_shift
22583           fac       = rij_shift**expon
22584           c1        = fac  * fac * aa_scbase(itypi,itypj)
22585 !          c1        = 0.0d0
22586           c2        = fac  * bb_scbase(itypi,itypj)
22587 !          c2        = 0.0d0
22588           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22589           eps2der   = eps3rt * evdwij
22590           eps3der   = eps2rt * evdwij
22591 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22592           evdwij    = eps2rt * eps3rt * evdwij
22593           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22594           fac    = -expon * (c1 + evdwij) * rij_shift
22595           sigder = fac * sigder
22596 !          fac    = rij * fac
22597 ! Calculate distance derivative
22598           gg(1) =  fac
22599           gg(2) =  fac
22600           gg(3) =  fac
22601 !          if (b2.gt.0.0) then
22602           fac = chis1 * sqom1 + chis2 * sqom2 &
22603           - 2.0d0 * chis12 * om1 * om2 * om12
22604 ! we will use pom later in Gcav, so dont mess with it!
22605           pom = 1.0d0 - chis1 * chis2 * sqom12
22606           Lambf = (1.0d0 - (fac / pom))
22607           Lambf = dsqrt(Lambf)
22608           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22609 !       write (*,*) "sparrow = ", sparrow
22610           Chif = 1.0d0/rij * sparrow
22611           ChiLambf = Chif * Lambf
22612           eagle = dsqrt(ChiLambf)
22613           bat = ChiLambf ** 11.0d0
22614           top = b1 * ( eagle + b2 * ChiLambf - b3 )
22615           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
22616           botsq = bot * bot
22617           Fcav = top / bot
22618 !          print *,i,j,Fcav
22619           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
22620           dbot = 12.0d0 * b4 * bat * Lambf
22621           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22622 !       dFdR = 0.0d0
22623 !      write (*,*) "dFcav/dR = ", dFdR
22624           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
22625           dbot = 12.0d0 * b4 * bat * Chif
22626           eagle = Lambf * pom
22627           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22628           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22629           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22630               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22631
22632           dFdL = ((dtop * bot - top * dbot) / botsq)
22633 !       dFdL = 0.0d0
22634           dCAVdOM1  = dFdL * ( dFdOM1 )
22635           dCAVdOM2  = dFdL * ( dFdOM2 )
22636           dCAVdOM12 = dFdL * ( dFdOM12 )
22637
22638           ertail(1) = xj*rij
22639           ertail(2) = yj*rij
22640           ertail(3) = zj*rij
22641 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
22642 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
22643 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
22644 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
22645 !           print *,"EOMY",eom1,eom2,eom12
22646 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22647 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
22648 ! here dtail=0.0
22649 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
22650 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22651        DO k = 1, 3
22652 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22653 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22654         pom = ertail(k)
22655 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22656         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22657                   - (( dFdR + gg(k) ) * pom)
22658 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22659 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22660 !     &             - ( dFdR * pom )
22661         pom = ertail(k)
22662 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22663         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22664                   + (( dFdR + gg(k) ) * pom)
22665 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22666 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22667 !c!     &             + ( dFdR * pom )
22668
22669         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22670                   - (( dFdR + gg(k) ) * ertail(k))
22671 !c!     &             - ( dFdR * ertail(k))
22672
22673         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22674                   + (( dFdR + gg(k) ) * ertail(k))
22675 !c!     &             + ( dFdR * ertail(k))
22676
22677         gg(k) = 0.0d0
22678 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22679 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22680       END DO
22681
22682 !          else
22683
22684 !          endif
22685 !Now dipole-dipole
22686          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
22687        w1 = wdipdip_scbase(1,itypi,itypj)
22688        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
22689        w3 = wdipdip_scbase(2,itypi,itypj)
22690 !c!-------------------------------------------------------------------
22691 !c! ECL
22692        fac = (om12 - 3.0d0 * om1 * om2)
22693        c1 = (w1 / (Rhead**3.0d0)) * fac
22694        c2 = (w2 / Rhead ** 6.0d0)  &
22695          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22696        c3= (w3/ Rhead ** 6.0d0)  &
22697          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22698        ECL = c1 - c2 + c3
22699 !c!       write (*,*) "w1 = ", w1
22700 !c!       write (*,*) "w2 = ", w2
22701 !c!       write (*,*) "om1 = ", om1
22702 !c!       write (*,*) "om2 = ", om2
22703 !c!       write (*,*) "om12 = ", om12
22704 !c!       write (*,*) "fac = ", fac
22705 !c!       write (*,*) "c1 = ", c1
22706 !c!       write (*,*) "c2 = ", c2
22707 !c!       write (*,*) "Ecl = ", Ecl
22708 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
22709 !c!       write (*,*) "c2_2 = ",
22710 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22711 !c!-------------------------------------------------------------------
22712 !c! dervative of ECL is GCL...
22713 !c! dECL/dr
22714        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
22715        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
22716          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
22717        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
22718          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22719        dGCLdR = c1 - c2 + c3
22720 !c! dECL/dom1
22721        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
22722        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22723          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
22724        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
22725        dGCLdOM1 = c1 - c2 + c3
22726 !c! dECL/dom2
22727        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
22728        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22729          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
22730        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
22731        dGCLdOM2 = c1 - c2 + c3
22732 !c! dECL/dom12
22733        c1 = w1 / (Rhead ** 3.0d0)
22734        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
22735        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
22736        dGCLdOM12 = c1 - c2 + c3
22737        DO k= 1, 3
22738         erhead(k) = Rhead_distance(k)/Rhead
22739        END DO
22740        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22741        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22742        facd1 = d1i * vbld_inv(i+nres)
22743        facd2 = d1j * vbld_inv(j+nres)
22744        DO k = 1, 3
22745
22746         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22747         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22748                   - dGCLdR * pom
22749         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22750         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22751                   + dGCLdR * pom
22752
22753         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22754                   - dGCLdR * erhead(k)
22755         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22756                   + dGCLdR * erhead(k)
22757        END DO
22758        endif
22759 !now charge with dipole eg. ARG-dG
22760        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
22761       alphapol1 = alphapol_scbase(itypi,itypj)
22762        w1        = wqdip_scbase(1,itypi,itypj)
22763        w2        = wqdip_scbase(2,itypi,itypj)
22764 !       w1=0.0d0
22765 !       w2=0.0d0
22766 !       pis       = sig0head_scbase(itypi,itypj)
22767 !       eps_head   = epshead_scbase(itypi,itypj)
22768 !c!-------------------------------------------------------------------
22769 !c! R1 - distance between head of ith side chain and tail of jth sidechain
22770        R1 = 0.0d0
22771        DO k = 1, 3
22772 !c! Calculate head-to-tail distances tail is center of side-chain
22773         R1=R1+(c(k,j+nres)-chead(k,1))**2
22774        END DO
22775 !c! Pitagoras
22776        R1 = dsqrt(R1)
22777
22778 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
22779 !c!     &        +dhead(1,1,itypi,itypj))**2))
22780 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
22781 !c!     &        +dhead(2,1,itypi,itypj))**2))
22782
22783 !c!-------------------------------------------------------------------
22784 !c! ecl
22785        sparrow  = w1  *  om1
22786        hawk     = w2 *  (1.0d0 - sqom2)
22787        Ecl = sparrow / Rhead**2.0d0 &
22788            - hawk    / Rhead**4.0d0
22789 !c!-------------------------------------------------------------------
22790 !c! derivative of ecl is Gcl
22791 !c! dF/dr part
22792        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
22793                 + 4.0d0 * hawk    / Rhead**5.0d0
22794 !c! dF/dom1
22795        dGCLdOM1 = (w1) / (Rhead**2.0d0)
22796 !c! dF/dom2
22797        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
22798 !c--------------------------------------------------------------------
22799 !c Polarization energy
22800 !c Epol
22801        MomoFac1 = (1.0d0 - chi1 * sqom2)
22802        RR1  = R1 * R1 / MomoFac1
22803        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
22804        fgb1 = sqrt( RR1 + a12sq * ee1)
22805 !       eps_inout_fac=0.0d0
22806        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
22807 ! derivative of Epol is Gpol...
22808        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
22809                 / (fgb1 ** 5.0d0)
22810        dFGBdR1 = ( (R1 / MomoFac1) &
22811              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
22812              / ( 2.0d0 * fgb1 )
22813        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
22814                * (2.0d0 - 0.5d0 * ee1) ) &
22815                / (2.0d0 * fgb1)
22816        dPOLdR1 = dPOLdFGB1 * dFGBdR1
22817 !       dPOLdR1 = 0.0d0
22818        dPOLdOM1 = 0.0d0
22819        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
22820        DO k = 1, 3
22821         erhead(k) = Rhead_distance(k)/Rhead
22822         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
22823        END DO
22824
22825        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22826        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22827        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
22828 !       bat=0.0d0
22829        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
22830        facd1 = d1i * vbld_inv(i+nres)
22831        facd2 = d1j * vbld_inv(j+nres)
22832 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22833
22834        DO k = 1, 3
22835         hawk = (erhead_tail(k,1) + &
22836         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
22837 !        facd1=0.0d0
22838 !        facd2=0.0d0
22839         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22840         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
22841                    - dGCLdR * pom &
22842                    - dPOLdR1 *  (erhead_tail(k,1))
22843 !     &             - dGLJdR * pom
22844
22845         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22846         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
22847                    + dGCLdR * pom  &
22848                    + dPOLdR1 * (erhead_tail(k,1))
22849 !     &             + dGLJdR * pom
22850
22851
22852         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
22853                   - dGCLdR * erhead(k) &
22854                   - dPOLdR1 * erhead_tail(k,1)
22855 !     &             - dGLJdR * erhead(k)
22856
22857         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
22858                   + dGCLdR * erhead(k)  &
22859                   + dPOLdR1 * erhead_tail(k,1)
22860 !     &             + dGLJdR * erhead(k)
22861
22862        END DO
22863        endif
22864 !       print *,i,j,evdwij,epol,Fcav,ECL
22865        escbase=escbase+evdwij+epol+Fcav+ECL
22866        call sc_grad_scbase
22867          enddo
22868       enddo
22869
22870       return
22871       end subroutine eprot_sc_base
22872       SUBROUTINE sc_grad_scbase
22873       use calc_data
22874
22875        real (kind=8) :: dcosom1(3),dcosom2(3)
22876        eom1  =    &
22877               eps2der * eps2rt_om1   &
22878             - 2.0D0 * alf1 * eps3der &
22879             + sigder * sigsq_om1     &
22880             + dCAVdOM1               &
22881             + dGCLdOM1               &
22882             + dPOLdOM1
22883
22884        eom2  =  &
22885               eps2der * eps2rt_om2   &
22886             + 2.0D0 * alf2 * eps3der &
22887             + sigder * sigsq_om2     &
22888             + dCAVdOM2               &
22889             + dGCLdOM2               &
22890             + dPOLdOM2
22891
22892        eom12 =    &
22893               evdwij  * eps1_om12     &
22894             + eps2der * eps2rt_om12   &
22895             - 2.0D0 * alf12 * eps3der &
22896             + sigder *sigsq_om12      &
22897             + dCAVdOM12               &
22898             + dGCLdOM12
22899
22900 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
22901 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
22902 !               gg(1),gg(2),"rozne"
22903        DO k = 1, 3
22904         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
22905         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
22906         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
22907         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
22908                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22909                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22910         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
22911                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22912                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22913         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
22914         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
22915        END DO
22916        RETURN
22917       END SUBROUTINE sc_grad_scbase
22918
22919
22920       subroutine epep_sc_base(epepbase)
22921       use calc_data
22922       logical :: lprn
22923 !el local variables
22924       integer :: iint,itypi,itypi1,itypj,subchap
22925       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22926       real(kind=8) :: evdw,sig0ij
22927       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22928                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22929                     sslipi,sslipj,faclip
22930       integer :: ii
22931       real(kind=8) :: fracinbuf
22932        real (kind=8) :: epepbase
22933        real (kind=8),dimension(4):: ener
22934        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22935        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22936         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22937         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22938         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22939         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22940         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22941         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22942        real(kind=8),dimension(3,2)::chead,erhead_tail
22943        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22944        integer troll
22945        eps_out=80.0d0
22946        epepbase=0.0d0
22947        do i=1,nres_molec(1)-1
22948         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
22949 !C        itypi  = itype(i,1)
22950         dxi    = dc_norm(1,i)
22951         dyi    = dc_norm(2,i)
22952         dzi    = dc_norm(3,i)
22953 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
22954         dsci_inv = vbld_inv(i+1)/2.0
22955         xi=(c(1,i)+c(1,i+1))/2.0
22956         yi=(c(2,i)+c(2,i+1))/2.0
22957         zi=(c(3,i)+c(3,i+1))/2.0
22958         xi=mod(xi,boxxsize)
22959          if (xi.lt.0) xi=xi+boxxsize
22960         yi=mod(yi,boxysize)
22961          if (yi.lt.0) yi=yi+boxysize
22962         zi=mod(zi,boxzsize)
22963          if (zi.lt.0) zi=zi+boxzsize
22964          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22965            itypj= itype(j,2)
22966            if (itype(j,2).eq.ntyp1_molec(2))cycle
22967            xj=c(1,j+nres)
22968            yj=c(2,j+nres)
22969            zj=c(3,j+nres)
22970            xj=dmod(xj,boxxsize)
22971            if (xj.lt.0) xj=xj+boxxsize
22972            yj=dmod(yj,boxysize)
22973            if (yj.lt.0) yj=yj+boxysize
22974            zj=dmod(zj,boxzsize)
22975            if (zj.lt.0) zj=zj+boxzsize
22976           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22977           xj_safe=xj
22978           yj_safe=yj
22979           zj_safe=zj
22980           subchap=0
22981
22982           do xshift=-1,1
22983           do yshift=-1,1
22984           do zshift=-1,1
22985           xj=xj_safe+xshift*boxxsize
22986           yj=yj_safe+yshift*boxysize
22987           zj=zj_safe+zshift*boxzsize
22988           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22989           if(dist_temp.lt.dist_init) then
22990             dist_init=dist_temp
22991             xj_temp=xj
22992             yj_temp=yj
22993             zj_temp=zj
22994             subchap=1
22995           endif
22996           enddo
22997           enddo
22998           enddo
22999           if (subchap.eq.1) then
23000           xj=xj_temp-xi
23001           yj=yj_temp-yi
23002           zj=zj_temp-zi
23003           else
23004           xj=xj_safe-xi
23005           yj=yj_safe-yi
23006           zj=zj_safe-zi
23007           endif
23008           dxj = dc_norm( 1, nres+j )
23009           dyj = dc_norm( 2, nres+j )
23010           dzj = dc_norm( 3, nres+j )
23011 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23012 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23013
23014 ! Gay-berne var's
23015           sig0ij = sigma_pepbase(itypj )
23016           chi1   = chi_pepbase(itypj,1 )
23017           chi2   = chi_pepbase(itypj,2 )
23018 !          chi1=0.0d0
23019 !          chi2=0.0d0
23020           chi12  = chi1 * chi2
23021           chip1  = chipp_pepbase(itypj,1 )
23022           chip2  = chipp_pepbase(itypj,2 )
23023 !          chip1=0.0d0
23024 !          chip2=0.0d0
23025           chip12 = chip1 * chip2
23026           chis1 = chis_pepbase(itypj,1)
23027           chis2 = chis_pepbase(itypj,2)
23028           chis12 = chis1 * chis2
23029           sig1 = sigmap1_pepbase(itypj)
23030           sig2 = sigmap2_pepbase(itypj)
23031 !       write (*,*) "sig1 = ", sig1
23032 !       write (*,*) "sig2 = ", sig2
23033        DO k = 1,3
23034 ! location of polar head is computed by taking hydrophobic centre
23035 ! and moving by a d1 * dc_norm vector
23036 ! see unres publications for very informative images
23037         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23038 ! + d1i * dc_norm(k, i+nres)
23039         chead(k,2) = c(k, j+nres)
23040 ! + d1j * dc_norm(k, j+nres)
23041 ! distance
23042 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23043 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23044         Rhead_distance(k) = chead(k,2) - chead(k,1)
23045 !        print *,gvdwc_pepbase(k,i)
23046
23047        END DO
23048        Rhead = dsqrt( &
23049           (Rhead_distance(1)*Rhead_distance(1)) &
23050         + (Rhead_distance(2)*Rhead_distance(2)) &
23051         + (Rhead_distance(3)*Rhead_distance(3)))
23052
23053 ! alpha factors from Fcav/Gcav
23054           b1 = alphasur_pepbase(1,itypj)
23055 !          b1=0.0d0
23056           b2 = alphasur_pepbase(2,itypj)
23057           b3 = alphasur_pepbase(3,itypj)
23058           b4 = alphasur_pepbase(4,itypj)
23059           alf1   = 0.0d0
23060           alf2   = 0.0d0
23061           alf12  = 0.0d0
23062           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23063 !          print *,i,j,rrij
23064           rij  = dsqrt(rrij)
23065 !----------------------------
23066        evdwij = 0.0d0
23067        ECL = 0.0d0
23068        Elj = 0.0d0
23069        Equad = 0.0d0
23070        Epol = 0.0d0
23071        Fcav=0.0d0
23072        eheadtail = 0.0d0
23073        dGCLdOM1 = 0.0d0
23074        dGCLdOM2 = 0.0d0
23075        dGCLdOM12 = 0.0d0
23076        dPOLdOM1 = 0.0d0
23077        dPOLdOM2 = 0.0d0
23078           Fcav = 0.0d0
23079           dFdR = 0.0d0
23080           dCAVdOM1  = 0.0d0
23081           dCAVdOM2  = 0.0d0
23082           dCAVdOM12 = 0.0d0
23083           dscj_inv = vbld_inv(j+nres)
23084           CALL sc_angular
23085 ! this should be in elgrad_init but om's are calculated by sc_angular
23086 ! which in turn is used by older potentials
23087 ! om = omega, sqom = om^2
23088           sqom1  = om1 * om1
23089           sqom2  = om2 * om2
23090           sqom12 = om12 * om12
23091
23092 ! now we calculate EGB - Gey-Berne
23093 ! It will be summed up in evdwij and saved in evdw
23094           sigsq     = 1.0D0  / sigsq
23095           sig       = sig0ij * dsqrt(sigsq)
23096           rij_shift = 1.0/rij - sig + sig0ij
23097           IF (rij_shift.le.0.0D0) THEN
23098            evdw = 1.0D20
23099            RETURN
23100           END IF
23101           sigder = -sig * sigsq
23102           rij_shift = 1.0D0 / rij_shift
23103           fac       = rij_shift**expon
23104           c1        = fac  * fac * aa_pepbase(itypj)
23105 !          c1        = 0.0d0
23106           c2        = fac  * bb_pepbase(itypj)
23107 !          c2        = 0.0d0
23108           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23109           eps2der   = eps3rt * evdwij
23110           eps3der   = eps2rt * evdwij
23111 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23112           evdwij    = eps2rt * eps3rt * evdwij
23113           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23114           fac    = -expon * (c1 + evdwij) * rij_shift
23115           sigder = fac * sigder
23116 !          fac    = rij * fac
23117 ! Calculate distance derivative
23118           gg(1) =  fac
23119           gg(2) =  fac
23120           gg(3) =  fac
23121           fac = chis1 * sqom1 + chis2 * sqom2 &
23122           - 2.0d0 * chis12 * om1 * om2 * om12
23123 ! we will use pom later in Gcav, so dont mess with it!
23124           pom = 1.0d0 - chis1 * chis2 * sqom12
23125           Lambf = (1.0d0 - (fac / pom))
23126           Lambf = dsqrt(Lambf)
23127           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23128 !       write (*,*) "sparrow = ", sparrow
23129           Chif = 1.0d0/rij * sparrow
23130           ChiLambf = Chif * Lambf
23131           eagle = dsqrt(ChiLambf)
23132           bat = ChiLambf ** 11.0d0
23133           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23134           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23135           botsq = bot * bot
23136           Fcav = top / bot
23137 !          print *,i,j,Fcav
23138           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23139           dbot = 12.0d0 * b4 * bat * Lambf
23140           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23141 !       dFdR = 0.0d0
23142 !      write (*,*) "dFcav/dR = ", dFdR
23143           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23144           dbot = 12.0d0 * b4 * bat * Chif
23145           eagle = Lambf * pom
23146           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23147           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23148           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23149               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23150
23151           dFdL = ((dtop * bot - top * dbot) / botsq)
23152 !       dFdL = 0.0d0
23153           dCAVdOM1  = dFdL * ( dFdOM1 )
23154           dCAVdOM2  = dFdL * ( dFdOM2 )
23155           dCAVdOM12 = dFdL * ( dFdOM12 )
23156
23157           ertail(1) = xj*rij
23158           ertail(2) = yj*rij
23159           ertail(3) = zj*rij
23160        DO k = 1, 3
23161 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23162 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23163         pom = ertail(k)
23164 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23165         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23166                   - (( dFdR + gg(k) ) * pom)/2.0
23167 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
23168 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23169 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23170 !     &             - ( dFdR * pom )
23171         pom = ertail(k)
23172 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23173         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23174                   + (( dFdR + gg(k) ) * pom)
23175 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23176 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23177 !c!     &             + ( dFdR * pom )
23178
23179         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23180                   - (( dFdR + gg(k) ) * ertail(k))/2.0
23181 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
23182
23183 !c!     &             - ( dFdR * ertail(k))
23184
23185         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23186                   + (( dFdR + gg(k) ) * ertail(k))
23187 !c!     &             + ( dFdR * ertail(k))
23188
23189         gg(k) = 0.0d0
23190 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23191 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23192       END DO
23193
23194
23195        w1 = wdipdip_pepbase(1,itypj)
23196        w2 = -wdipdip_pepbase(3,itypj)/2.0
23197        w3 = wdipdip_pepbase(2,itypj)
23198 !       w1=0.0d0
23199 !       w2=0.0d0
23200 !c!-------------------------------------------------------------------
23201 !c! ECL
23202 !       w3=0.0d0
23203        fac = (om12 - 3.0d0 * om1 * om2)
23204        c1 = (w1 / (Rhead**3.0d0)) * fac
23205        c2 = (w2 / Rhead ** 6.0d0)  &
23206          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23207        c3= (w3/ Rhead ** 6.0d0)  &
23208          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23209
23210        ECL = c1 - c2 + c3
23211
23212        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23213        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23214          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23215        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23216          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23217
23218        dGCLdR = c1 - c2 + c3
23219 !c! dECL/dom1
23220        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23221        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23222          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23223        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23224        dGCLdOM1 = c1 - c2 + c3
23225 !c! dECL/dom2
23226        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23227        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23228          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23229        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23230
23231        dGCLdOM2 = c1 - c2 + c3
23232 !c! dECL/dom12
23233        c1 = w1 / (Rhead ** 3.0d0)
23234        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23235        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23236        dGCLdOM12 = c1 - c2 + c3
23237        DO k= 1, 3
23238         erhead(k) = Rhead_distance(k)/Rhead
23239        END DO
23240        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23241        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23242 !       facd1 = d1 * vbld_inv(i+nres)
23243 !       facd2 = d2 * vbld_inv(j+nres)
23244        DO k = 1, 3
23245
23246 !        pom = erhead(k)
23247 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23248 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
23249 !                  - dGCLdR * pom
23250         pom = erhead(k)
23251 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23252         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23253                   + dGCLdR * pom
23254
23255         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23256                   - dGCLdR * erhead(k)/2.0d0
23257 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23258         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23259                   - dGCLdR * erhead(k)/2.0d0
23260 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23261         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23262                   + dGCLdR * erhead(k)
23263        END DO
23264 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
23265        epepbase=epepbase+evdwij+Fcav+ECL
23266        call sc_grad_pepbase
23267        enddo
23268        enddo
23269       END SUBROUTINE epep_sc_base
23270       SUBROUTINE sc_grad_pepbase
23271       use calc_data
23272
23273        real (kind=8) :: dcosom1(3),dcosom2(3)
23274        eom1  =    &
23275               eps2der * eps2rt_om1   &
23276             - 2.0D0 * alf1 * eps3der &
23277             + sigder * sigsq_om1     &
23278             + dCAVdOM1               &
23279             + dGCLdOM1               &
23280             + dPOLdOM1
23281
23282        eom2  =  &
23283               eps2der * eps2rt_om2   &
23284             + 2.0D0 * alf2 * eps3der &
23285             + sigder * sigsq_om2     &
23286             + dCAVdOM2               &
23287             + dGCLdOM2               &
23288             + dPOLdOM2
23289
23290        eom12 =    &
23291               evdwij  * eps1_om12     &
23292             + eps2der * eps2rt_om12   &
23293             - 2.0D0 * alf12 * eps3der &
23294             + sigder *sigsq_om12      &
23295             + dCAVdOM12               &
23296             + dGCLdOM12
23297 !        om12=0.0
23298 !        eom12=0.0
23299 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23300 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
23301 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23302 !                 *dsci_inv*2.0
23303 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23304 !               gg(1),gg(2),"rozne"
23305        DO k = 1, 3
23306         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
23307         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23308         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23309         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
23310                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23311                  *dsci_inv*2.0 &
23312                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23313         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
23314                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
23315                  *dsci_inv*2.0 &
23316                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23317 !         print *,eom12,eom2,om12,om2
23318 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23319 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23320         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
23321                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23322                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23323         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
23324        END DO
23325        RETURN
23326       END SUBROUTINE sc_grad_pepbase
23327       subroutine eprot_sc_phosphate(escpho)
23328       use calc_data
23329 !      implicit real*8 (a-h,o-z)
23330 !      include 'DIMENSIONS'
23331 !      include 'COMMON.GEO'
23332 !      include 'COMMON.VAR'
23333 !      include 'COMMON.LOCAL'
23334 !      include 'COMMON.CHAIN'
23335 !      include 'COMMON.DERIV'
23336 !      include 'COMMON.NAMES'
23337 !      include 'COMMON.INTERACT'
23338 !      include 'COMMON.IOUNITS'
23339 !      include 'COMMON.CALC'
23340 !      include 'COMMON.CONTROL'
23341 !      include 'COMMON.SBRIDGE'
23342       logical :: lprn
23343 !el local variables
23344       integer :: iint,itypi,itypi1,itypj,subchap
23345       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23346       real(kind=8) :: evdw,sig0ij
23347       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23348                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23349                     sslipi,sslipj,faclip
23350       integer :: ii
23351       real(kind=8) :: fracinbuf
23352        real (kind=8) :: escpho
23353        real (kind=8),dimension(4):: ener
23354        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23355        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23356         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23357         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23358         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23359         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23360         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23361         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23362        real(kind=8),dimension(3,2)::chead,erhead_tail
23363        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23364        integer troll
23365        eps_out=80.0d0
23366        escpho=0.0d0
23367        do i=1,nres_molec(1)
23368         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23369         itypi  = itype(i,1)
23370         dxi    = dc_norm(1,nres+i)
23371         dyi    = dc_norm(2,nres+i)
23372         dzi    = dc_norm(3,nres+i)
23373         dsci_inv = vbld_inv(i+nres)
23374         xi=c(1,nres+i)
23375         yi=c(2,nres+i)
23376         zi=c(3,nres+i)
23377         xi=mod(xi,boxxsize)
23378          if (xi.lt.0) xi=xi+boxxsize
23379         yi=mod(yi,boxysize)
23380          if (yi.lt.0) yi=yi+boxysize
23381         zi=mod(zi,boxzsize)
23382          if (zi.lt.0) zi=zi+boxzsize
23383          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23384            itypj= itype(j,2)
23385            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23386             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23387            xj=(c(1,j)+c(1,j+1))/2.0
23388            yj=(c(2,j)+c(2,j+1))/2.0
23389            zj=(c(3,j)+c(3,j+1))/2.0
23390            xj=dmod(xj,boxxsize)
23391            if (xj.lt.0) xj=xj+boxxsize
23392            yj=dmod(yj,boxysize)
23393            if (yj.lt.0) yj=yj+boxysize
23394            zj=dmod(zj,boxzsize)
23395            if (zj.lt.0) zj=zj+boxzsize
23396           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23397           xj_safe=xj
23398           yj_safe=yj
23399           zj_safe=zj
23400           subchap=0
23401           do xshift=-1,1
23402           do yshift=-1,1
23403           do zshift=-1,1
23404           yj=yj_safe+yshift*boxysize
23405           zj=zj_safe+zshift*boxzsize
23406           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23407           if(dist_temp.lt.dist_init) then
23408             dist_init=dist_temp
23409             xj_temp=xj
23410             yj_temp=yj
23411             zj_temp=zj
23412             subchap=1
23413           endif
23414           enddo
23415           enddo
23416           enddo
23417           if (subchap.eq.1) then
23418           xj=xj_temp-xi
23419           yj=yj_temp-yi
23420           zj=zj_temp-zi
23421           else
23422           xj=xj_safe-xi
23423           yj=yj_safe-yi
23424           zj=zj_safe-zi
23425           endif
23426           dxj = dc_norm( 1,j )
23427           dyj = dc_norm( 2,j )
23428           dzj = dc_norm( 3,j )
23429           dscj_inv = vbld_inv(j+1)
23430
23431 ! Gay-berne var's
23432           sig0ij = sigma_scpho(itypi )
23433           chi1   = chi_scpho(itypi,1 )
23434           chi2   = chi_scpho(itypi,2 )
23435 !          chi1=0.0d0
23436 !          chi2=0.0d0
23437           chi12  = chi1 * chi2
23438           chip1  = chipp_scpho(itypi,1 )
23439           chip2  = chipp_scpho(itypi,2 )
23440 !          chip1=0.0d0
23441 !          chip2=0.0d0
23442           chip12 = chip1 * chip2
23443           chis1 = chis_scpho(itypi,1)
23444           chis2 = chis_scpho(itypi,2)
23445           chis12 = chis1 * chis2
23446           sig1 = sigmap1_scpho(itypi)
23447           sig2 = sigmap2_scpho(itypi)
23448 !       write (*,*) "sig1 = ", sig1
23449 !       write (*,*) "sig1 = ", sig1
23450 !       write (*,*) "sig2 = ", sig2
23451 ! alpha factors from Fcav/Gcav
23452           alf1   = 0.0d0
23453           alf2   = 0.0d0
23454           alf12  = 0.0d0
23455           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
23456
23457           b1 = alphasur_scpho(1,itypi)
23458 !          b1=0.0d0
23459           b2 = alphasur_scpho(2,itypi)
23460           b3 = alphasur_scpho(3,itypi)
23461           b4 = alphasur_scpho(4,itypi)
23462 ! used to determine whether we want to do quadrupole calculations
23463 ! used by Fgb
23464        eps_in = epsintab_scpho(itypi)
23465        if (eps_in.eq.0.0) eps_in=1.0
23466        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23467 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23468 !-------------------------------------------------------------------
23469 ! tail location and distance calculations
23470           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
23471           d1j = 0.0
23472        DO k = 1,3
23473 ! location of polar head is computed by taking hydrophobic centre
23474 ! and moving by a d1 * dc_norm vector
23475 ! see unres publications for very informative images
23476         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23477         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
23478 ! distance
23479 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23480 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23481         Rhead_distance(k) = chead(k,2) - chead(k,1)
23482        END DO
23483 ! pitagoras (root of sum of squares)
23484        Rhead = dsqrt( &
23485           (Rhead_distance(1)*Rhead_distance(1)) &
23486         + (Rhead_distance(2)*Rhead_distance(2)) &
23487         + (Rhead_distance(3)*Rhead_distance(3)))
23488        Rhead_sq=Rhead**2.0
23489 !-------------------------------------------------------------------
23490 ! zero everything that should be zero'ed
23491        evdwij = 0.0d0
23492        ECL = 0.0d0
23493        Elj = 0.0d0
23494        Equad = 0.0d0
23495        Epol = 0.0d0
23496        Fcav=0.0d0
23497        eheadtail = 0.0d0
23498        dGCLdR=0.0d0
23499        dGCLdOM1 = 0.0d0
23500        dGCLdOM2 = 0.0d0
23501        dGCLdOM12 = 0.0d0
23502        dPOLdOM1 = 0.0d0
23503        dPOLdOM2 = 0.0d0
23504           Fcav = 0.0d0
23505           dFdR = 0.0d0
23506           dCAVdOM1  = 0.0d0
23507           dCAVdOM2  = 0.0d0
23508           dCAVdOM12 = 0.0d0
23509           dscj_inv = vbld_inv(j+1)/2.0
23510 !dhead_scbasej(itypi,itypj)
23511 !          print *,i,j,dscj_inv,dsci_inv
23512 ! rij holds 1/(distance of Calpha atoms)
23513           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23514           rij  = dsqrt(rrij)
23515 !----------------------------
23516           CALL sc_angular
23517 ! this should be in elgrad_init but om's are calculated by sc_angular
23518 ! which in turn is used by older potentials
23519 ! om = omega, sqom = om^2
23520           sqom1  = om1 * om1
23521           sqom2  = om2 * om2
23522           sqom12 = om12 * om12
23523
23524 ! now we calculate EGB - Gey-Berne
23525 ! It will be summed up in evdwij and saved in evdw
23526           sigsq     = 1.0D0  / sigsq
23527           sig       = sig0ij * dsqrt(sigsq)
23528 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23529           rij_shift = 1.0/rij - sig + sig0ij
23530           IF (rij_shift.le.0.0D0) THEN
23531            evdw = 1.0D20
23532            RETURN
23533           END IF
23534           sigder = -sig * sigsq
23535           rij_shift = 1.0D0 / rij_shift
23536           fac       = rij_shift**expon
23537           c1        = fac  * fac * aa_scpho(itypi)
23538 !          c1        = 0.0d0
23539           c2        = fac  * bb_scpho(itypi)
23540 !          c2        = 0.0d0
23541           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23542           eps2der   = eps3rt * evdwij
23543           eps3der   = eps2rt * evdwij
23544 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23545           evdwij    = eps2rt * eps3rt * evdwij
23546           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23547           fac    = -expon * (c1 + evdwij) * rij_shift
23548           sigder = fac * sigder
23549 !          fac    = rij * fac
23550 ! Calculate distance derivative
23551           gg(1) =  fac
23552           gg(2) =  fac
23553           gg(3) =  fac
23554           fac = chis1 * sqom1 + chis2 * sqom2 &
23555           - 2.0d0 * chis12 * om1 * om2 * om12
23556 ! we will use pom later in Gcav, so dont mess with it!
23557           pom = 1.0d0 - chis1 * chis2 * sqom12
23558           Lambf = (1.0d0 - (fac / pom))
23559           Lambf = dsqrt(Lambf)
23560           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23561 !       write (*,*) "sparrow = ", sparrow
23562           Chif = 1.0d0/rij * sparrow
23563           ChiLambf = Chif * Lambf
23564           eagle = dsqrt(ChiLambf)
23565           bat = ChiLambf ** 11.0d0
23566           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23567           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23568           botsq = bot * bot
23569           Fcav = top / bot
23570           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23571           dbot = 12.0d0 * b4 * bat * Lambf
23572           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23573 !       dFdR = 0.0d0
23574 !      write (*,*) "dFcav/dR = ", dFdR
23575           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23576           dbot = 12.0d0 * b4 * bat * Chif
23577           eagle = Lambf * pom
23578           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23579           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23580           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23581               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23582
23583           dFdL = ((dtop * bot - top * dbot) / botsq)
23584 !       dFdL = 0.0d0
23585           dCAVdOM1  = dFdL * ( dFdOM1 )
23586           dCAVdOM2  = dFdL * ( dFdOM2 )
23587           dCAVdOM12 = dFdL * ( dFdOM12 )
23588
23589           ertail(1) = xj*rij
23590           ertail(2) = yj*rij
23591           ertail(3) = zj*rij
23592        DO k = 1, 3
23593 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23594 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23595 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
23596
23597         pom = ertail(k)
23598 !        print *,pom,gg(k),dFdR
23599 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23600         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
23601                   - (( dFdR + gg(k) ) * pom)
23602 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23603 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23604 !     &             - ( dFdR * pom )
23605 !        pom = ertail(k)
23606 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23607 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
23608 !                  + (( dFdR + gg(k) ) * pom)
23609 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23610 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23611 !c!     &             + ( dFdR * pom )
23612
23613         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
23614                   - (( dFdR + gg(k) ) * ertail(k))
23615 !c!     &             - ( dFdR * ertail(k))
23616
23617         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
23618                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23619
23620         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
23621                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23622
23623 !c!     &             + ( dFdR * ertail(k))
23624
23625         gg(k) = 0.0d0
23626         ENDDO
23627 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23628 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23629 !      alphapol1 = alphapol_scpho(itypi)
23630        if (wqq_scpho(itypi).gt.0.0) then
23631        Qij=wqq_scpho(itypi)/eps_in
23632 !       Qij=0.0
23633        Ecl = (332.0d0 * Qij) / Rhead
23634 !c! derivative of Ecl is Gcl...
23635        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
23636        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
23637        w1        = wqdip_scpho(1,itypi)
23638        w2        = wqdip_scpho(2,itypi)
23639 !       w1=0.0d0
23640 !       w2=0.0d0
23641 !       pis       = sig0head_scbase(itypi,itypj)
23642 !       eps_head   = epshead_scbase(itypi,itypj)
23643 !c!-------------------------------------------------------------------
23644
23645 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23646 !c!     &        +dhead(1,1,itypi,itypj))**2))
23647 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23648 !c!     &        +dhead(2,1,itypi,itypj))**2))
23649
23650 !c!-------------------------------------------------------------------
23651 !c! ecl
23652        sparrow  = w1  *  om1
23653        hawk     = w2 *  (1.0d0 - sqom2)
23654        Ecl = sparrow / Rhead**2.0d0 &
23655            - hawk    / Rhead**4.0d0
23656 !c!-------------------------------------------------------------------
23657 !c! derivative of ecl is Gcl
23658 !c! dF/dr part
23659        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23660                 + 4.0d0 * hawk    / Rhead**5.0d0
23661 !c! dF/dom1
23662        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23663 !c! dF/dom2
23664        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23665        endif
23666
23667 !c--------------------------------------------------------------------
23668 !c Polarization energy
23669 !c Epol
23670        R1 = 0.0d0
23671        DO k = 1, 3
23672 !c! Calculate head-to-tail distances tail is center of side-chain
23673         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
23674        END DO
23675 !c! Pitagoras
23676        R1 = dsqrt(R1)
23677
23678       alphapol1 = alphapol_scpho(itypi)
23679 !      alphapol1=0.0
23680        MomoFac1 = (1.0d0 - chi2 * sqom1)
23681        RR1  = R1 * R1 / MomoFac1
23682        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23683 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
23684        fgb1 = sqrt( RR1 + a12sq * ee1)
23685 !       eps_inout_fac=0.0d0
23686        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23687 ! derivative of Epol is Gpol...
23688        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23689                 / (fgb1 ** 5.0d0)
23690        dFGBdR1 = ( (R1 / MomoFac1) &
23691              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23692              / ( 2.0d0 * fgb1 )
23693        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23694                * (2.0d0 - 0.5d0 * ee1) ) &
23695                / (2.0d0 * fgb1)
23696        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23697 !       dPOLdR1 = 0.0d0
23698 !       dPOLdOM1 = 0.0d0
23699        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
23700                * (2.0d0 - 0.5d0 * ee1) ) &
23701                / (2.0d0 * fgb1)
23702
23703        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
23704        dPOLdOM2 = 0.0
23705        DO k = 1, 3
23706         erhead(k) = Rhead_distance(k)/Rhead
23707         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
23708        END DO
23709
23710        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23711        erdxj = scalar( erhead(1), dC_norm(1,j) )
23712        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23713 !       bat=0.0d0
23714        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
23715        facd1 = d1i * vbld_inv(i+nres)
23716        facd2 = d1j * vbld_inv(j)
23717 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23718
23719        DO k = 1, 3
23720         hawk = (erhead_tail(k,1) + &
23721         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23722 !        facd1=0.0d0
23723 !        facd2=0.0d0
23724 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
23725 !                pom,(erhead_tail(k,1))
23726
23727 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
23728         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23729         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
23730                    - dGCLdR * pom &
23731                    - dPOLdR1 *  (erhead_tail(k,1))
23732 !     &             - dGLJdR * pom
23733
23734         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
23735 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
23736 !                   + dGCLdR * pom  &
23737 !                   + dPOLdR1 * (erhead_tail(k,1))
23738 !     &             + dGLJdR * pom
23739
23740
23741         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
23742                   - dGCLdR * erhead(k) &
23743                   - dPOLdR1 * erhead_tail(k,1)
23744 !     &             - dGLJdR * erhead(k)
23745
23746         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
23747                   + (dGCLdR * erhead(k)  &
23748                   + dPOLdR1 * erhead_tail(k,1))/2.0
23749         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
23750                   + (dGCLdR * erhead(k)  &
23751                   + dPOLdR1 * erhead_tail(k,1))/2.0
23752
23753 !     &             + dGLJdR * erhead(k)
23754 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
23755
23756        END DO
23757 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
23758        escpho=escpho+evdwij+epol+Fcav+ECL
23759        call sc_grad_scpho
23760          enddo
23761
23762       enddo
23763
23764       return
23765       end subroutine eprot_sc_phosphate
23766       SUBROUTINE sc_grad_scpho
23767       use calc_data
23768
23769        real (kind=8) :: dcosom1(3),dcosom2(3)
23770        eom1  =    &
23771               eps2der * eps2rt_om1   &
23772             - 2.0D0 * alf1 * eps3der &
23773             + sigder * sigsq_om1     &
23774             + dCAVdOM1               &
23775             + dGCLdOM1               &
23776             + dPOLdOM1
23777
23778        eom2  =  &
23779               eps2der * eps2rt_om2   &
23780             + 2.0D0 * alf2 * eps3der &
23781             + sigder * sigsq_om2     &
23782             + dCAVdOM2               &
23783             + dGCLdOM2               &
23784             + dPOLdOM2
23785
23786        eom12 =    &
23787               evdwij  * eps1_om12     &
23788             + eps2der * eps2rt_om12   &
23789             - 2.0D0 * alf12 * eps3der &
23790             + sigder *sigsq_om12      &
23791             + dCAVdOM12               &
23792             + dGCLdOM12
23793 !        om12=0.0
23794 !        eom12=0.0
23795 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23796 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
23797 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23798 !                 *dsci_inv*2.0
23799 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23800 !               gg(1),gg(2),"rozne"
23801        DO k = 1, 3
23802         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23803         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
23804         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23805         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
23806                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
23807                  *dscj_inv*2.0 &
23808                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23809         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
23810                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
23811                  *dscj_inv*2.0 &
23812                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23813         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
23814                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
23815                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23816
23817 !         print *,eom12,eom2,om12,om2
23818 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23819 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23820 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
23821 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23822 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23823         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
23824        END DO
23825        RETURN
23826       END SUBROUTINE sc_grad_scpho
23827       subroutine eprot_pep_phosphate(epeppho)
23828       use calc_data
23829 !      implicit real*8 (a-h,o-z)
23830 !      include 'DIMENSIONS'
23831 !      include 'COMMON.GEO'
23832 !      include 'COMMON.VAR'
23833 !      include 'COMMON.LOCAL'
23834 !      include 'COMMON.CHAIN'
23835 !      include 'COMMON.DERIV'
23836 !      include 'COMMON.NAMES'
23837 !      include 'COMMON.INTERACT'
23838 !      include 'COMMON.IOUNITS'
23839 !      include 'COMMON.CALC'
23840 !      include 'COMMON.CONTROL'
23841 !      include 'COMMON.SBRIDGE'
23842       logical :: lprn
23843 !el local variables
23844       integer :: iint,itypi,itypi1,itypj,subchap
23845       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23846       real(kind=8) :: evdw,sig0ij
23847       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23848                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23849                     sslipi,sslipj,faclip
23850       integer :: ii
23851       real(kind=8) :: fracinbuf
23852        real (kind=8) :: epeppho
23853        real (kind=8),dimension(4):: ener
23854        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23855        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23856         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23857         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23858         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23859         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23860         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23861         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23862        real(kind=8),dimension(3,2)::chead,erhead_tail
23863        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23864        integer troll
23865        real (kind=8) :: dcosom1(3),dcosom2(3)
23866        epeppho=0.0d0
23867        do i=1,nres_molec(1)
23868         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23869         itypi  = itype(i,1)
23870         dsci_inv = vbld_inv(i+1)/2.0
23871         dxi    = dc_norm(1,i)
23872         dyi    = dc_norm(2,i)
23873         dzi    = dc_norm(3,i)
23874         xi=(c(1,i)+c(1,i+1))/2.0
23875         yi=(c(2,i)+c(2,i+1))/2.0
23876         zi=(c(3,i)+c(3,i+1))/2.0
23877         xi=mod(xi,boxxsize)
23878          if (xi.lt.0) xi=xi+boxxsize
23879         yi=mod(yi,boxysize)
23880          if (yi.lt.0) yi=yi+boxysize
23881         zi=mod(zi,boxzsize)
23882          if (zi.lt.0) zi=zi+boxzsize
23883          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23884            itypj= itype(j,2)
23885            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23886             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23887            xj=(c(1,j)+c(1,j+1))/2.0
23888            yj=(c(2,j)+c(2,j+1))/2.0
23889            zj=(c(3,j)+c(3,j+1))/2.0
23890            xj=dmod(xj,boxxsize)
23891            if (xj.lt.0) xj=xj+boxxsize
23892            yj=dmod(yj,boxysize)
23893            if (yj.lt.0) yj=yj+boxysize
23894            zj=dmod(zj,boxzsize)
23895            if (zj.lt.0) zj=zj+boxzsize
23896           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23897           xj_safe=xj
23898           yj_safe=yj
23899           zj_safe=zj
23900           subchap=0
23901           do xshift=-1,1
23902           do yshift=-1,1
23903           do zshift=-1,1
23904           yj=yj_safe+yshift*boxysize
23905           zj=zj_safe+zshift*boxzsize
23906           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23907           if(dist_temp.lt.dist_init) then
23908             dist_init=dist_temp
23909             xj_temp=xj
23910             yj_temp=yj
23911             zj_temp=zj
23912             subchap=1
23913           endif
23914           enddo
23915           enddo
23916           enddo
23917           if (subchap.eq.1) then
23918           xj=xj_temp-xi
23919           yj=yj_temp-yi
23920           zj=zj_temp-zi
23921           else
23922           xj=xj_safe-xi
23923           yj=yj_safe-yi
23924           zj=zj_safe-zi
23925           endif
23926           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23927           rij  = dsqrt(rrij)
23928           dxj = dc_norm( 1,j )
23929           dyj = dc_norm( 2,j )
23930           dzj = dc_norm( 3,j )
23931           dscj_inv = vbld_inv(j+1)/2.0
23932 ! Gay-berne var's
23933           sig0ij = sigma_peppho
23934           chi1=0.0d0
23935           chi2=0.0d0
23936           chi12  = chi1 * chi2
23937           chip1=0.0d0
23938           chip2=0.0d0
23939           chip12 = chip1 * chip2
23940           chis1 = 0.0d0
23941           chis2 = 0.0d0
23942           chis12 = chis1 * chis2
23943           sig1 = sigmap1_peppho
23944           sig2 = sigmap2_peppho
23945 !       write (*,*) "sig1 = ", sig1
23946 !       write (*,*) "sig1 = ", sig1
23947 !       write (*,*) "sig2 = ", sig2
23948 ! alpha factors from Fcav/Gcav
23949           alf1   = 0.0d0
23950           alf2   = 0.0d0
23951           alf12  = 0.0d0
23952           b1 = alphasur_peppho(1)
23953 !          b1=0.0d0
23954           b2 = alphasur_peppho(2)
23955           b3 = alphasur_peppho(3)
23956           b4 = alphasur_peppho(4)
23957           CALL sc_angular
23958        sqom1=om1*om1
23959        evdwij = 0.0d0
23960        ECL = 0.0d0
23961        Elj = 0.0d0
23962        Equad = 0.0d0
23963        Epol = 0.0d0
23964        Fcav=0.0d0
23965        eheadtail = 0.0d0
23966        dGCLdR=0.0d0
23967        dGCLdOM1 = 0.0d0
23968        dGCLdOM2 = 0.0d0
23969        dGCLdOM12 = 0.0d0
23970        dPOLdOM1 = 0.0d0
23971        dPOLdOM2 = 0.0d0
23972           Fcav = 0.0d0
23973           dFdR = 0.0d0
23974           dCAVdOM1  = 0.0d0
23975           dCAVdOM2  = 0.0d0
23976           dCAVdOM12 = 0.0d0
23977           rij_shift = rij
23978           fac       = rij_shift**expon
23979           c1        = fac  * fac * aa_peppho
23980 !          c1        = 0.0d0
23981           c2        = fac  * bb_peppho
23982 !          c2        = 0.0d0
23983           evdwij    =  c1 + c2
23984 ! Now cavity....................
23985        eagle = dsqrt(1.0/rij_shift)
23986        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
23987           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
23988           botsq = bot * bot
23989           Fcav = top / bot
23990           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
23991           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
23992           dFdR = ((dtop * bot - top * dbot) / botsq)
23993        w1        = wqdip_peppho(1)
23994        w2        = wqdip_peppho(2)
23995 !       w1=0.0d0
23996 !       w2=0.0d0
23997 !       pis       = sig0head_scbase(itypi,itypj)
23998 !       eps_head   = epshead_scbase(itypi,itypj)
23999 !c!-------------------------------------------------------------------
24000
24001 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24002 !c!     &        +dhead(1,1,itypi,itypj))**2))
24003 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24004 !c!     &        +dhead(2,1,itypi,itypj))**2))
24005
24006 !c!-------------------------------------------------------------------
24007 !c! ecl
24008        sparrow  = w1  *  om1
24009        hawk     = w2 *  (1.0d0 - sqom1)
24010        Ecl = sparrow * rij_shift**2.0d0 &
24011            - hawk    * rij_shift**4.0d0
24012 !c!-------------------------------------------------------------------
24013 !c! derivative of ecl is Gcl
24014 !c! dF/dr part
24015 !       rij_shift=5.0
24016        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24017                 + 4.0d0 * hawk    * rij_shift**5.0d0
24018 !c! dF/dom1
24019        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24020 !c! dF/dom2
24021        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24022        eom1  =    dGCLdOM1+dGCLdOM2
24023        eom2  =    0.0
24024
24025           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24026 !          fac=0.0
24027           gg(1) =  fac*xj*rij
24028           gg(2) =  fac*yj*rij
24029           gg(3) =  fac*zj*rij
24030          do k=1,3
24031          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24032          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24033          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24034          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24035          gg(k)=0.0
24036          enddo
24037
24038       DO k = 1, 3
24039         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24040         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24041         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24042         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24043 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24044         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24045 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24046         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24047                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24048         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24049                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24050         enddo
24051        epeppho=epeppho+evdwij+Fcav+ECL
24052 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24053        enddo
24054        enddo
24055       end subroutine eprot_pep_phosphate
24056       end module energy